Stuff

IntersectMBO · Jun 19, 2021 · c63c273 · c63c273
1 parent d9cb8da
commit c63c273
Showing 1 changed file with 48 additions and 42 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -23,6 +25,7 @@ import           Data.Aeson (ToJSON (..), (.=))
 import qualified Data.Aeson as Aeson
 import           Data.Aeson.Encode.Pretty (encodePretty)
 import qualified Data.ByteString.Lazy.Char8 as LBS
+import qualified Data.HashMap.Strict as HMS
 import           Data.List (nub)
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
@@ -207,54 +210,50 @@ runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
         ChainTipAtGenesis -> 0
         ChainTip slotNo _ _ -> slotNo
 
-  mEpoch <- case consensusMode of
-    CardanoMode -> logExceptContinue renderShelleyQueryCmdError $ do
-      let epochQuery = QueryEraHistory CardanoModeIsMultiEra
-      eResult <- liftIO $ queryNodeLocalState localNodeConnInfo Nothing epochQuery
-      case eResult of
-        Left acqFail -> left (ShelleyQueryCmdAcquireFailure acqFail)
-        Right eraHistory -> case slotToEpoch tipSlotNo eraHistory of
-          Left e -> throwE (ShelleyQueryCmdPastHorizon e)
-          Right a -> return (tuple3Fst @EpochNo @SlotsInEpoch @SlotsToEpochEnd a)
-
-    mode -> left (ShelleyQueryCmdUnsupportedMode (AnyConsensusMode mode))
-
-  tipTimeResult <- case consensusMode of
+  result :: R.QueryTipResult2 <- case consensusMode of
     CardanoMode -> do
-      let epochQuery = QueryEraHistory CardanoModeIsMultiEra  -- QueryInShelleyBasedEra sbe QueryEpoch
-      eResult <- liftIO $ queryNodeLocalState localNodeConnInfo Nothing epochQuery
-      case eResult of
-        Left acqFail -> left (ShelleyQueryCmdGeneric (show acqFail))
-        Right eraHistory -> return $ first toJsonPastHorizonException $ fmap fst (getProgress tipSlotNo eraHistory)
-
-    mode -> left (ShelleyQueryCmdGeneric ("Not cardano mode: " <> show mode))
-
-  let jsonTipTime :: Aeson.Value = either identity (toJSON . relativeTimeSeconds) tipTimeResult
+      a :: Maybe EpochNo <- logExceptContinue renderShelleyQueryCmdError $ do
+        let epochQuery = QueryEraHistory CardanoModeIsMultiEra
+        eResult <- liftIO $ queryNodeLocalState localNodeConnInfo Nothing epochQuery
+        case eResult of
+          Left acqFail -> left (ShelleyQueryCmdAcquireFailure acqFail)
+          Right eraHistory -> case slotToEpoch tipSlotNo eraHistory of
+            Left e -> throwE (ShelleyQueryCmdPastHorizon e)
+            Right a -> return (tuple3Fst @EpochNo @SlotsInEpoch @SlotsToEpochEnd a)
+
+      b :: Either Aeson.Value RelativeTime <- do
+        let epochQuery = QueryEraHistory CardanoModeIsMultiEra  -- QueryInShelleyBasedEra sbe QueryEpoch
+        eResult <- liftIO $ queryNodeLocalState localNodeConnInfo Nothing epochQuery
+        case eResult of
+          Left acqFail -> left (ShelleyQueryCmdGeneric (show acqFail))
+          Right eraHistory -> return $ first toJsonPastHorizonException $ fmap fst (getProgress tipSlotNo eraHistory)
+
+      c :: UTCTime <- do
+        let epochQuery = QuerySystemStart CardanoModeIsMultiEra  -- QueryInShelleyBasedEra sbe QueryEpoch
+        eResult <- liftIO $ queryNodeLocalState localNodeConnInfo Nothing epochQuery
+        case eResult of
+          Left acqFail -> left (ShelleyQueryCmdGeneric (show acqFail))
+          Right systemStart -> return (getSystemStart systemStart)
+
+      return $ R.QueryTipResult2 a b c
 
-  systemStart <- case consensusMode of
-    CardanoMode -> do
-      let epochQuery = QuerySystemStart CardanoModeIsMultiEra  -- QueryInShelleyBasedEra sbe QueryEpoch
-      eResult <- liftIO $ queryNodeLocalState localNodeConnInfo Nothing epochQuery
-      case eResult of
-        Left acqFail -> left (ShelleyQueryCmdGeneric (show acqFail))
-        Right systemStart -> return (getSystemStart systemStart)
+    mode -> left (ShelleyQueryCmdUnsupportedMode (AnyConsensusMode mode))
 
-    mode -> left (ShelleyQueryCmdGeneric ("Not cardano mode: " <> show mode))
+  let jsonTipTime :: Aeson.Value = either identity (toJSON . relativeTimeSeconds) (R.tipTimeResult result)
 
-  nowSeconds <- toRelativeTime (SystemStart systemStart) <$> liftIO getCurrentTime
+  nowSeconds <- toRelativeTime (SystemStart (R.systemStart (result :: R.QueryTipResult2))) <$> liftIO getCurrentTime
 
   let tolerance = RelativeTime (secondsToNominalDiffTime 600)
-  let jsonSyncProgress = either identity (toJSON . flip (percentage tolerance) nowSeconds) tipTimeResult
-
-  let output = encodePretty $ toJSON $ R.QueryTipResult
-        { R.era = toJSON anyEra
-        , R.epoch = mEpoch
-        , R.tipTime = jsonTipTime
-        , R.now = relativeTimeSeconds nowSeconds
-        , R.syncProgress = jsonSyncProgress
-        , R.systemStart = systemStart
-        , R.chainTip = tip
-        }
+  let jsonSyncProgress = either identity (toJSON . flip (percentage tolerance) nowSeconds) (R.tipTimeResult result)
+
+  let output = encodePretty
+        . toObject "era" (Just (toJSON anyEra))
+        . toObject "epoch" (R.mEpoch (result :: R.QueryTipResult2))
+        . toObject "tipTime" (Just jsonTipTime)
+        . toObject "now" (Just (relativeTimeSeconds nowSeconds))
+        . toObject "syncProgress" (Just jsonSyncProgress)
+        . toObject "systemStart" (Just (R.systemStart (result :: R.QueryTipResult2)))
+        $ toJSON tip
 
   case mOutFile of
     Just (OutputFile fpath) -> liftIO $ LBS.writeFile fpath output
@@ -264,6 +263,13 @@ runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
     tuple3Fst :: (a, b, c) -> a
     tuple3Fst (a, _, _) = a
 
+    toObject :: ToJSON a => Text -> Maybe a -> Aeson.Value -> Aeson.Value
+    toObject name (Just a) (Aeson.Object obj) =
+      Aeson.Object $ obj <> HMS.fromList [name .= toJSON a]
+    toObject name Nothing (Aeson.Object obj) =
+      Aeson.Object $ obj <> HMS.fromList [name .= Aeson.Null]
+    toObject _ _ _ = Aeson.Null
+
 toJsonPastHorizonException :: Qry.PastHorizonException -> Aeson.Value
 toJsonPastHorizonException e = Aeson.object
   [ "error" .= Aeson.String "Past Horizon"