From e667af3a55ff5c500e772379c5376990887d3ed7 Mon Sep 17 00:00:00 2001
From: John Ky <john.ky@iohk.io>
Date: Fri, 28 Jul 2023 10:18:08 +1000
Subject: [PATCH] More shelleyBasedEraConstraint constraints

---
 .../internal/Cardano/Api/Eras/Constraints.hs  |  2 +
 cardano-api/internal/Cardano/Api/Orphans.hs   | 76 ++++++++++++++++++-
 2 files changed, 77 insertions(+), 1 deletion(-)

diff --git a/cardano-api/internal/Cardano/Api/Eras/Constraints.hs b/cardano-api/internal/Cardano/Api/Eras/Constraints.hs
index 5440f8e1e7..a4e0c9daa0 100644
--- a/cardano-api/internal/Cardano/Api/Eras/Constraints.hs
+++ b/cardano-api/internal/Cardano/Api/Eras/Constraints.hs
@@ -16,6 +16,7 @@ module Cardano.Api.Eras.Constraints
 
 import           Cardano.Api.Eras.Core
 import           Cardano.Api.Modes
+import           Cardano.Api.Orphans ()
 import           Cardano.Api.Query.Types
 
 import qualified Cardano.Crypto.Hash.Blake2b as Blake2b
@@ -68,6 +69,7 @@ type ShelleyBasedEraConstraints era ledgerera =
   , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
   , FromCBOR (DebugLedgerState era)
   , IsShelleyBasedEra era
+  , ToJSON (Consensus.ChainDepState (ConsensusProtocol era))
   , ToJSON (DebugLedgerState era)
   , Typeable era
   )
diff --git a/cardano-api/internal/Cardano/Api/Orphans.hs b/cardano-api/internal/Cardano/Api/Orphans.hs
index d62e48e1a4..dff24848cc 100644
--- a/cardano-api/internal/Cardano/Api/Orphans.hs
+++ b/cardano-api/internal/Cardano/Api/Orphans.hs
@@ -1,20 +1,46 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Cardano.Api.Orphans () where
 
 import           Cardano.Binary (DecoderError (..))
+import qualified Cardano.Ledger.Crypto as CC (Crypto)
 import qualified Cardano.Ledger.Crypto as Crypto
+import qualified Cardano.Protocol.TPraos.API as Ledger
+import           Cardano.Protocol.TPraos.BHeader (HashHeader (..))
+import qualified Cardano.Protocol.TPraos.Rules.Prtcl as Ledger
+import qualified Cardano.Protocol.TPraos.Rules.Tickn as Ledger
+import           Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..))
+import           Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..))
+import           Ouroboros.Consensus.Protocol.Praos (PraosState)
+import qualified Ouroboros.Consensus.Protocol.Praos as Consensus
+import           Ouroboros.Consensus.Protocol.TPraos (TPraosState)
+import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus
+import           Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
+import           Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyHash (..))
 import qualified Ouroboros.Consensus.Shelley.Ledger.Query as Consensus
+import           Ouroboros.Network.Block (HeaderHash, Tip (..))
 
 import qualified Codec.Binary.Bech32 as Bech32
 import qualified Codec.CBOR.Read as CBOR
-import           Data.Aeson (ToJSON (..), object, pairs, (.=))
+import           Data.Aeson (KeyValue ((.=)), ToJSON (..), object, pairs, (.=))
 import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Short as SBS
 import           Data.Data (Data)
+import qualified Data.Text.Encoding as Text
 
 deriving instance Data DecoderError
 deriving instance Data CBOR.DeserialiseFailure
@@ -57,3 +83,51 @@ stakeSnapshotToPair Consensus.StakeSnapshot
     , "stakeSet" .= ssSetPool
     , "stakeGo" .= ssGoPool
     ]
+
+instance ToJSON (OneEraHash xs) where
+  toJSON = toJSON
+         . Text.decodeLatin1
+         . Base16.encode
+         . SBS.fromShort
+         . getOneEraHash
+
+deriving newtype instance ToJSON ByronHash
+
+-- This instance is temporarily duplicated in cardano-config
+
+instance ToJSON (HeaderHash blk) => ToJSON (Tip blk) where
+  toJSON TipGenesis = Aeson.object [ "genesis" .= True ]
+  toJSON (Tip slotNo headerHash blockNo) =
+    Aeson.object
+      [ "slotNo"     .= slotNo
+      , "headerHash" .= headerHash
+      , "blockNo"    .= blockNo
+      ]
+
+--
+-- Simple newtype wrappers JSON conversion
+--
+
+deriving newtype instance CC.Crypto crypto => ToJSON (ShelleyHash crypto)
+deriving newtype instance CC.Crypto crypto => ToJSON (HashHeader crypto)
+
+deriving instance ToJSON (Ledger.PrtclState StandardCrypto)
+deriving instance ToJSON Ledger.TicknState
+deriving instance ToJSON (Ledger.ChainDepState StandardCrypto)
+
+instance ToJSON (TPraosState StandardCrypto) where
+  toJSON s = Aeson.object
+    [ "lastSlot" .= Consensus.tpraosStateLastSlot s
+    , "chainDepState" .= Consensus.tpraosStateChainDepState s
+    ]
+
+instance ToJSON (PraosState StandardCrypto) where
+  toJSON s = Aeson.object
+    [ "lastSlot" .= Consensus.praosStateLastSlot s
+    , "oCertCounters" .= Consensus.praosStateOCertCounters s
+    , "evolvingNonce" .= Consensus.praosStateEvolvingNonce s
+    , "candidateNonce" .= Consensus.praosStateCandidateNonce s
+    , "epochNonce" .= Consensus.praosStateEpochNonce s
+    , "labNonce" .= Consensus.praosStateLabNonce s
+    , "lastEpochBlockNonce" .= Consensus.praosStateLastEpochBlockNonce s
+    ]