Remove lens

IntersectMBO · Jun 30, 2022 · 736666c · 736666c
1 parent bcc2824
commit 736666c
Show file tree

Hide file tree

Showing 3 changed files with 59 additions and 32 deletions.
diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal
@@ -43,8 +43,6 @@ library
                       , hedgehog-extras
                       , http-client
                       , http-types
-                      , lens
-                      , lens-aeson
                       , ouroboros-network
                       , process
                       , random

diff --git a/cardano-testnet/src/Test/Assert.hs b/cardano-testnet/src/Test/Assert.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -9,29 +10,30 @@ module Test.Assert
   , getRelevantLeaderSlots
   ) where
 
-import Control.Lens ((^.), (^?), to)
+import Control.Applicative ((<*>))
 import Control.Monad (Monad(..))
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Reader (ReaderT)
 import Control.Monad.Trans.Resource (ResourceT)
-import Data.Aeson (Value)
+import Data.Aeson (FromJSON(..), Value, (.:))
 import Data.Bool (Bool(..))
 import Data.Eq (Eq (..))
 import Data.Function ((.), ($))
 import Data.Functor ((<$>))
 import Data.Int (Int)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe, Maybe (..))
 import Data.Ord (Ord(..))
+import Data.Text (Text)
 import GHC.Stack (HasCallStack)
 import Hedgehog (MonadTest)
 import Hedgehog.Extras.Internal.Test.Integration (IntegrationState)
-import Prelude (fromIntegral)
 import System.FilePath (FilePath)
 import System.IO (IO)
 import Test.Runtime (NodeLoggingFormat(..))
+import Text.Show (Show(..))
 
-import qualified Data.Aeson as J
-import qualified Data.Aeson.Lens as J
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.List as L
 import qualified Data.Maybe as Maybe
@@ -42,12 +44,12 @@ import qualified Hedgehog.Extras.Test.Base as H
 import qualified Test.Process as H
 
 readJsonLines :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m [Value]
-readJsonLines fp = mapMaybe (J.decode @Value) . LBS.split 10 <$> H.evalIO (LBS.readFile fp)
+readJsonLines fp = mapMaybe (Aeson.decode @Value) . LBS.split 10 <$> H.evalIO (LBS.readFile fp)
 
 fileJsonGrep :: FilePath -> (Value -> Bool) -> IO Bool
 fileJsonGrep fp f = do
   lines <- LBS.split 10 <$> LBS.readFile fp
-  let jsons = mapMaybe (J.decode @Value) lines
+  let jsons = mapMaybe (Aeson.decode @Value) lines
   return $ L.any f jsons
 
 assertChainExtended :: (H.MonadTest m, MonadIO m)
@@ -59,14 +61,42 @@ assertChainExtended deadline nodeLoggingFormat nodeStdoutFile =
   H.assertByDeadlineIOCustom "Chain not extended" deadline $ do
     case nodeLoggingFormat of
       NodeLoggingFormatAsText -> IO.fileContains "Chain extended, new tip" nodeStdoutFile
-      NodeLoggingFormatAsJson -> fileJsonGrep nodeStdoutFile (\v -> v ^. J.key "data" . J.key "kind" . J._String == "")
+      NodeLoggingFormatAsJson -> fileJsonGrep nodeStdoutFile $ \v ->
+                                    Aeson.parseMaybe (Aeson.parseJSON @(LogEntry Kind)) v == Just (LogEntry (Kind "TraceAddBlockEvent.AddedToCurrentChain"))
+
+newtype LogEntry a = LogEntry
+  { data_ :: a
+  } deriving (Eq, Show)
+
+instance FromJSON a => FromJSON (LogEntry a) where
+  parseJSON = Aeson.withObject "LogEntry" $ \v ->
+    LogEntry <$> v .: "data"
+
+newtype Kind = Kind
+  { kind :: Text
+  } deriving (Eq, Show)
+
+data TraceNodeIsLeader = TraceNodeIsLeader
+  { kind :: Text
+  , slot :: Int
+  } deriving (Eq, Show)
+
+instance FromJSON TraceNodeIsLeader where
+  parseJSON = Aeson.withObject "TraceNodeIsLeader" $ \v ->
+    TraceNodeIsLeader
+      <$> v .: "kind"
+      <*> v .: "slot"
+
+instance FromJSON Kind where
+  parseJSON = Aeson.withObject "Kind" $ \v ->
+    Kind <$> v .: "kind"
 
 getRelevantLeaderSlots :: FilePath -> Int -> H.PropertyT (ReaderT IntegrationState (ResourceT IO)) [Int]
 getRelevantLeaderSlots poolNodeStdoutFile slotLowerBound = do
   vs <- readJsonLines poolNodeStdoutFile
   leaderSlots <- H.noteShow
-    $ Maybe.mapMaybe (\v -> v ^? J.key "data" . J.key "val" . J.key "slot" . J._Integer . to fromIntegral)
-    $ L.filter       (\v -> v ^. J.key "data" . J.key "val" . J.key "kind" . J._String == "TraceNodeIsLeader")
+    $ L.map (slot . data_)
+    $ Maybe.mapMaybe (Aeson.parseMaybe (Aeson.parseJSON @(LogEntry TraceNodeIsLeader)))
     vs
   relevantLeaderSlots <- H.noteShow
     $ L.filter       (>= slotLowerBound)

diff --git a/cardano-testnet/src/Testnet/Babbage.hs b/cardano-testnet/src/Testnet/Babbage.hs
@@ -22,7 +22,6 @@ module Testnet.Babbage
   ) where
 
 import           Control.Applicative (Applicative(..))
-import           Control.Lens ((.~))
 import           Control.Monad (Monad (..), forM_, void, forM, (=<<), when, fmap, return)
 import           Data.Aeson ((.=))
 import           Data.Bool (Bool(..))
@@ -42,7 +41,6 @@ import           Test.Runtime (Delegator(..), NodeLoggingFormat(..), PaymentKeyP
 import           Text.Show (Show(show))
 
 import qualified Data.Aeson as J
-import qualified Data.Aeson.Lens as J
 import qualified Data.HashMap.Lazy as HM
 import qualified Data.List as L
 import qualified Data.Time.Clock as DTC
@@ -244,23 +242,24 @@ testnet testnetOptions H.Conf {..} = do
   H.renameFile (tempAbsPath </> "genesis.alonzo.json") (tempAbsPath </> "genesis/shelley/genesis.alonzo.json")
   H.renameFile (tempAbsPath </> "genesis.json") (tempAbsPath </> "genesis/shelley/genesis.json")
 
-  H.rewriteJsonFile (tempAbsPath </> "genesis/byron/genesis.json")
-    $ J.key "protocolConsts" . J.key "protocolMagic" .~ J.toJSON @Int testnetMagic
-
-  H.rewriteJsonFile (tempAbsPath </> "genesis/shelley/genesis.json")
-    ( (J.key "slotLength"             .~ J.toJSON @Double 0.1)
-    . (J.key "activeSlotsCoeff"       .~ J.toJSON @Double 0.1)
-    . (J.key "securityParam"          .~ J.toJSON @Int 10)
-    . (J.key "epochLength"            .~ J.toJSON @Int 500)
-    . (J.key "maxLovelaceSupply"      .~ J.toJSON @Int 1000000000000)
-    . (J.key "minFeeA"                .~ J.toJSON @Int 44)
-    . (J.key "minFeeB"                .~ J.toJSON @Int 155381)
-    . (J.key "minUTxOValue"           .~ J.toJSON @Int 1000000)
-    . (J.key "decentralisationParam"  .~ J.toJSON @Double 0.7)
-    . (J.key "major"                  .~ J.toJSON @Int 7)
-    . (J.key "rho"                    .~ J.toJSON @Double 0.1)
-    . (J.key "tau"                    .~ J.toJSON @Double 0.1)
-    . (J.key "updateQuorum"           .~ J.toJSON @Int 2)
+  H.rewriteJsonFile (tempAbsPath </> "genesis/byron/genesis.json") $ J.rewriteObject
+    $ flip HM.adjust "protocolConsts"
+      ( J.rewriteObject ( HM.insert "protocolMagic" (J.toJSON @Int testnetMagic)))
+
+  H.rewriteJsonFile (tempAbsPath </> "genesis/shelley/genesis.json") $ J.rewriteObject
+    ( HM.insert "slotLength"             (J.toJSON @Double 0.1)
+    . HM.insert "activeSlotsCoeff"       (J.toJSON @Double 0.1)
+    . HM.insert "securityParam"          (J.toJSON @Int 10)
+    . HM.insert "epochLength"            (J.toJSON @Int 500)
+    . HM.insert "maxLovelaceSupply"      (J.toJSON @Int 1000000000000)
+    . HM.insert "minFeeA"                (J.toJSON @Int 44)
+    . HM.insert "minFeeB"                (J.toJSON @Int 155381)
+    . HM.insert "minUTxOValue"           (J.toJSON @Int 1000000)
+    . HM.insert "decentralisationParam"  (J.toJSON @Double 0.7)
+    . HM.insert "major"                  (J.toJSON @Int 7)
+    . HM.insert "rho"                    (J.toJSON @Double 0.1)
+    . HM.insert "tau"                    (J.toJSON @Double 0.1)
+    . HM.insert "updateQuorum"           (J.toJSON @Int 2)
     )
 
   H.renameFile (tempAbsPath </> "pools/vrf1.skey") (tempAbsPath </> "node-spo1/vrf.skey")