WIP

cardano-api/src/Cardano/Api/Block.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -46,7 +48,7 @@ module Cardano.Api.Block (
 
 import           Prelude
 
-import           Data.Aeson (ToJSON (..), object, (.=))
+import           Data.Aeson (FromJSON (..), ToJSON (..), object, (.=))
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Short as SBS
@@ -69,15 +71,16 @@ import qualified Ouroboros.Network.Block as Consensus
 
 import qualified Cardano.Chain.Block as Byron
 import qualified Cardano.Chain.UTxO as Byron
+import qualified Cardano.Ledger.Block as Ledger
 import qualified Cardano.Ledger.Era as Ledger
 import qualified Cardano.Protocol.TPraos.BHeader as TPraos
-import qualified Cardano.Ledger.Block as Ledger
 
 import           Cardano.Api.Eras
 import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.Hash
 import           Cardano.Api.Modes
 import           Cardano.Api.SerialiseRaw
+import           Cardano.Api.SerialiseUsing
 import           Cardano.Api.Tx
 
 {- HLINT ignore "Use lambda" -}
@@ -237,6 +240,9 @@ data BlockHeader = BlockHeader !SlotNo
 -- representation.
 newtype instance Hash BlockHeader = HeaderHash SBS.ShortByteString
   deriving (Eq, Ord, Show)
+  deriving (ToJSON, FromJSON) via UsingRawBytesHex (Hash BlockHeader)
+
+
 
 instance SerialiseAsRawBytes (Hash BlockHeader) where
     serialiseToRawBytes (HeaderHash bs) = SBS.fromShort bs

cardano-api/src/Cardano/Api/Eras.hs

@@ -45,14 +45,12 @@ module Cardano.Api.Eras
 
 import           Prelude
 
-import           Data.Aeson (ToJSON, toJSON)
+import           Data.Aeson (FromJSON (..), ToJSON, toJSON, withText)
+import qualified Data.Text as Text
 import           Data.Type.Equality (TestEquality (..), (:~:) (Refl))
 
-import           Ouroboros.Consensus.Shelley.Eras as Ledger
-                   (StandardShelley,
-                    StandardAllegra,
-                    StandardMary,
-                    StandardAlonzo)
+import           Ouroboros.Consensus.Shelley.Eras as Ledger (StandardAllegra, StandardAlonzo,
+                   StandardMary, StandardShelley)
 
 import           Cardano.Api.HasTypeProxy
 
@@ -203,6 +201,17 @@ instance Eq AnyCardanoEra where
 instance ToJSON AnyCardanoEra where
    toJSON (AnyCardanoEra era) = toJSON era
 
+instance FromJSON AnyCardanoEra where
+   parseJSON = withText "AnyCardanoEra" $ \t ->
+      case t of
+        "Byron" -> pure $ AnyCardanoEra ByronEra
+        "Shelley" -> pure $ AnyCardanoEra ShelleyEra
+        "Allegra" -> pure $ AnyCardanoEra AllegraEra
+        "Mary" -> pure $ AnyCardanoEra MaryEra
+        "Alonzo" -> pure $ AnyCardanoEra AlonzoEra
+        wrong -> fail $ "Failed to parse unknown era: " <> Text.unpack wrong
+
+
 -- | Like the 'AnyCardanoEra' constructor but does not demand a 'IsCardanoEra'
 -- class constraint.
 --

cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs

@@ -38,9 +38,9 @@ import qualified Cardano.Ledger.Credential as Ledger
 import qualified Cardano.Ledger.Shelley.API.Protocol as Ledger
 import qualified Cardano.Ledger.Shelley.EpochBoundary as Ledger
 import qualified Cardano.Ledger.Shelley.Rewards as Ledger
+import           Cardano.Ledger.TxIn (TxId (..))
 import qualified Cardano.Protocol.TPraos.Rules.Prtcl as Ledger
 import qualified Cardano.Protocol.TPraos.Rules.Tickn as Ledger
-import           Cardano.Ledger.TxIn (TxId (..))
 
 import qualified Cardano.Ledger.Mary.Value as Ledger.Mary
 
@@ -64,8 +64,8 @@ instance ToJSON (HeaderHash blk) => ToJSON (Tip blk) where
       , "blockNo"    .= blockNo
       ]
 
--- This instance is temporarily duplicated in cardano-config
 deriving newtype instance ToJSON BlockNo
+deriving newtype instance FromJSON BlockNo
 
 --
 -- Simple newtype wrappers JSON conversion

cardano-cli/src/Cardano/CLI/Shelley/Output.hs

@@ -7,17 +7,15 @@ module Cardano.CLI.Shelley.Output
   ) where
 
 import           Cardano.Api
+import           Prelude
+
+import           Data.Aeson (KeyValue, ToJSON (..), withObject, (.:?), (.=))
+import qualified Data.Aeson as J
+import           Data.Text (Text)
 
 import           Cardano.CLI.Shelley.Orphans ()
-import           Cardano.Prelude (Text)
-import           Cardano.Slotting.Time (SystemStart (..))
-import           Data.Aeson (KeyValue, ToJSON (..), (.=))
-import           Data.Function (id, ($), (.))
-import           Data.Maybe ( Maybe(..) )
-import           Data.Monoid (mconcat)
 import           Cardano.Ledger.Shelley.Scripts ()
-
-import qualified Data.Aeson as J
+import           Cardano.Slotting.Time (SystemStart (..))
 
 data QueryTipLocalState mode = QueryTipLocalState
   { era :: AnyCardanoEra
@@ -31,7 +29,7 @@ data QueryTipLocalStateOutput = QueryTipLocalStateOutput
   , mEra :: Maybe AnyCardanoEra
   , mEpoch :: Maybe EpochNo
   , mSyncProgress :: Maybe Text
-  }
+  } deriving Show
 
 -- | A key-value pair difference list for encoding a JSON object.
 (..=) :: (KeyValue kv, ToJSON v) => Text -> v -> [kv] -> [kv]
@@ -76,3 +74,30 @@ instance ToJSON QueryTipLocalStateOutput where
         . ("epoch" ..=? mEpoch a)
         . ("syncProgress" ..=? mSyncProgress a)
         ) []
+
+instance FromJSON QueryTipLocalStateOutput where
+  parseJSON = withObject "QueryTipLocalStateOutput" $ \o -> do
+    mEra' <- o .:? "era"
+    mEpoch' <- o .:? "epoch"
+    mSyncProgress' <- o .:? "syncProgress"
+
+    mSlot <- o .:? "slot"
+    mHash <- o .:? "hash"
+    mBlock <- o .:? "block"
+    case (mSlot, mHash, mBlock) of
+      (Nothing, Nothing, Nothing) ->
+        pure $ QueryTipLocalStateOutput
+                 ChainTipAtGenesis
+                 mEra'
+                 mEpoch'
+                 mSyncProgress'
+      (Just slot, Just hash, Just block) ->
+        pure $ QueryTipLocalStateOutput
+                 (ChainTip slot hash block)
+                 mEra'
+                 mEpoch'
+                 mSyncProgress'
+      (_,_,_) -> fail "QueryTipLocalStateOutput was incorrectly JSON encoded.\
+                      \ Expected slot, header hash and block number (ChainTip) or none (ChainTipAtGenesis)"
+
+

cardano-testnet/cardano-testnet.cabal

@@ -36,6 +36,8 @@ library
   build-depends:        aeson
                       , base16-bytestring
                       , bytestring
+                      , cardano-api
+                      , cardano-cli
                       , containers
                       , directory
                       , exceptions
@@ -47,6 +49,7 @@ library
                       , process
                       , random
                       , resourcet
+                      , safe-exceptions
                       , text
                       , time
                       , unordered-containers
@@ -61,6 +64,7 @@ library
                         Testnet.List
                         Testnet.Shelley
                         Testnet.SubmitApi
+                        Testnet.Utils
 
 executable cardano-testnet
   import:               base, project-config

cardano-testnet/src/Testnet/Utils.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Testnet.Utils
+  ( waitUntilEpoch
+  ) where
+
+import           Cardano.Api
+
+import           Control.Concurrent (threadDelay)
+import           Control.Exception.Safe (MonadCatch)
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Data.Aeson (fromJSON)
+import           Data.Eq
+import           Data.Function
+import           Data.Int
+import           Data.Maybe
+import           GHC.Stack
+import           System.Directory (doesFileExist, removeFile)
+import           System.FilePath (FilePath)
+import           Text.Show
+
+import           Cardano.CLI.Shelley.Output
+
+import qualified Hedgehog.Extras.Test.Base as H
+import qualified Hedgehog.Extras.Test.File as H
+import           Hedgehog.Extras.Test.Process (ExecConfig)
+import           Hedgehog.Internal.Property (MonadTest)
+import qualified Test.Process as H
+
+-- | Submit the desired epoch to wait to.
+waitUntilEpoch
+  :: (MonadCatch m, MonadIO m, MonadTest m)
+  => FilePath
+  -- ^ Output file
+  -> Int
+  -- ^ Testnet magic
+  -> ExecConfig
+  -> EpochNo
+  -- ^ Desired epoch
+  -> m EpochNo
+waitUntilEpoch fp testnetMagic execConfig desiredEpoch = do
+  exists <- liftIO $ doesFileExist fp
+  if exists
+  then liftIO $ removeFile fp
+  else return ()
+
+  void $ H.execCli' execConfig
+    [ "query",  "tip"
+    , "--testnet-magic", show @Int testnetMagic
+    , "--out-file", fp
+    ]
+  tipJSON <- H.leftFailM $ H.readJsonFile fp
+  tip <- H.noteShowM $ H.jsonErrorFail $ fromJSON @QueryTipLocalStateOutput tipJSON
+  epoch <- case mEpoch tip of
+             Nothing ->
+               H.failMessage callStack "waitUntilEpoch: cardano-cli query tip returned Nothing for EpochNo"
+             Just currEpoch ->
+               if currEpoch == desiredEpoch
+               then return currEpoch
+               else do liftIO $ threadDelay 10_000_000
+                       waitUntilEpoch fp testnetMagic execConfig desiredEpoch
+  return epoch

cardano-testnet/test/Spec/Plutus/Direct/CertifyingPlutus.hs

@@ -22,10 +22,12 @@ import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.String
 import qualified Data.Text as T
+import           GHC.Stack (callStack)
 import qualified System.Directory as IO
 import           System.Environment (getEnvironment)
 import           System.FilePath ((</>))
 
+import           Cardano.CLI.Shelley.Output
 import           Cardano.CLI.Shelley.Run.Query
 
 import           Hedgehog (Property, (===))
@@ -37,9 +39,11 @@ import qualified Hedgehog.Extras.Test.File as H
 import qualified Hedgehog.Extras.Test.Process as H
 import qualified Test.Base as H
 import qualified Test.Process as H
-import           Testnet.Cardano (defaultTestnetOptions, testnet)
+import           Testnet.Cardano (TestnetOptions (..), TestnetRuntime (..), defaultTestnetOptions,
+                   testnet)
 import qualified Testnet.Cardano as TC
 import qualified Testnet.Conf as H
+import           Testnet.Utils (waitUntilEpoch)
 
 
 {-
@@ -56,7 +60,11 @@ hprop_plutus_certifying = H.integration . H.runFinallies . H.workspace "chairman
   projectBase <- H.note =<< H.noteIO . IO.canonicalizePath =<< H.getProjectBase
   conf@H.Conf { H.tempBaseAbsPath, H.tempAbsPath } <- H.noteShowM $ H.mkConf tempAbsBasePath' Nothing
 
-  TC.TestnetRuntime { bftSprockets, testnetMagic } <- testnet defaultTestnetOptions conf
+  let fastTestnetOptions = defaultTestnetOptions
+                             { epochLength = 100
+                             , slotLength = 0.1
+                             }
+  TC.TestnetRuntime { bftSprockets, testnetMagic } <- testnet fastTestnetOptions conf
 
   env <- H.evalIO getEnvironment
 
@@ -119,9 +127,6 @@ hprop_plutus_certifying = H.integration . H.runFinallies . H.workspace "chairman
                              , "--testnet-magic", show @Int testnetMagic
                              ]
 
-  scriptDummyRedeemer <- H.note $ work </> "mint-script-context-dummy.redeemer"
-  scriptContextRedeemer <- H.note $ work </> "mint-script-context.redeemer"
-
   -- Plutus related
   plutusStakingScript <- H.note $ base </> "scripts/plutus/scripts/guess-42-stake.plutus"
   plutusStakingScriptRedeemer <- H.note $ base </> "scripts/plutus/data/42.redeemer"
@@ -396,7 +401,6 @@ hprop_plutus_certifying = H.integration . H.runFinallies . H.workspace "chairman
   utxo3Json <- H.leftFailM . H.readJsonFile $ work </> "utxo-3.json"
   UTxO utxo3 <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(UTxO AlonzoEra) utxo3Json
   txin3 <- H.noteShow $ Map.keys utxo3 !! 0
-  txinCollateral <- H.noteShow $ Map.keys utxo3 !! 1
 
   void $ H.execCli
     [ "stake-address", "registration-certificate"
@@ -535,16 +539,52 @@ hprop_plutus_certifying = H.integration . H.runFinallies . H.workspace "chairman
   H.note_ $ "Check plutus staking script: " <> (work </> "plutus-staking-script-delegation.json") <> " was delegated"
   T.unpack (serialiseAddress stakingSAddr) === plutusStakingAddr
 
-  H.note "Wait for rewards to be paid out. This will be current epoch + 4"
-  -- TODO: Get current epoch. Add 4 to it. Loop and check.
-  -- when we hut n + 4 check stake address info to see
-  -- if we have a non-zero value in there.
+  H.note_ "Wait for rewards to be paid out. This will be current epoch + 4"
 
-  -- TODO: Left off here
-  tipJSON <- H.execCli' execConfig
+  void $ H.execCli' execConfig
     [ "query",  "tip"
     , "--testnet-magic", show @Int testnetMagic
-    , "--out-file", work </> ""
+    , "--out-file", work </> "current-tip.json"
+    ]
+
+  tipJSON <- H.leftFailM . H.readJsonFile $ work </> "current-tip.json"
+  tip <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @QueryTipLocalStateOutput tipJSON
+  currEpoch <-
+    case mEpoch tip of
+      Nothing ->
+        H.failMessage callStack "cardano-cli query tip returned Nothing for EpochNo"
+      Just currEpoch -> return currEpoch
+
+  let rewardsEpoch = currEpoch + 5
+  waitedEpoch <- waitUntilEpoch
+                   (work </> "current-tip.json")
+                   testnetMagic
+                   execConfig
+                   rewardsEpoch
+
+  H.note_ "Check we have reached 4 epochs ahead"
+  waitedEpoch === rewardsEpoch
+
+  H.note_ "Check rewards have been distributed to Plutus script staking address"
+
+  void $ H.execCli' execConfig
+    [ "query",  "stake-address-info"
+    , "--address", plutusStakingAddr
+    , "--testnet-magic", show @Int testnetMagic
+    , "--out-file", work </> "plutus-staking-script-delegation-rewards.json"
+    ]
+
+  stakingRewardsJSON <- H.leftFailM . H.readJsonFile $ work </> "plutus-staking-script-delegation-rewards.json"
+  delegsAndRewardsMapScriptRewards <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @DelegationsAndRewards stakingRewardsJSON
+  let delegsAndRewardsScriptRewards = mergeDelegsAndRewards delegsAndRewardsMapScriptRewards
+      stakingScriptRewardsAddrInfo = filter (\(sAddr,_,_) -> plutusStakingAddr == T.unpack (serialiseAddress sAddr)) delegsAndRewardsScriptRewards
+      (_, scriptRewards, _) = head stakingScriptRewardsAddrInfo
+  case scriptRewards of
+    Nothing -> H.failMessage callStack "Plutus staking script had no rewards"
+    Just rwds -> (rwds > 0) === True
+    -- TODO: Left off here. For some reason the rewards are zero. Maybe you need to adjust slot length and epoch length
+    -- to be the same as your scripts
+
 {-
 
   policyId <- filter (/= '\n')