Convert to not use lenses

IntersectMBO · Jul 7, 2021 · 5753ef6 · 5753ef6
1 parent cbab29c
commit 5753ef6
Show file tree

Hide file tree

Showing 3 changed files with 30 additions and 20 deletions.
diff --git a/cabal.project b/cabal.project
@@ -110,8 +110,8 @@ package cardano-ledger-alonzo-test
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/hedgehog-extras
-  tag: 7ffbd217bb969d7c01f1e70cf58535df06e5d9a8
-  --sha256: 0sjlk19v0dg63v8dawg844y3wzm1nmq0qxpvhip81x5yi091jjmm
+  tag: f7adf144bbd6da1aae9a668f40a1f8fdf69c9135
+  --sha256: 03g53wfwhbxsy8izaz0yl84gg841gc14mlzv69aamfpw8ckvm05g
 
 source-repository-package
   type: git

diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal
@@ -101,8 +101,6 @@ test-suite cardano-testnet-tests
                       , hedgehog
                       , hedgehog-extras
                       , filepath
-                      , lens
-                      , lens-aeson
                       , tasty
                       , tasty-hedgehog
                       , text

diff --git a/cardano-testnet/test/Spec/Plutus/Direct/TxInLockingPlutus.hs b/cardano-testnet/test/Spec/Plutus/Direct/TxInLockingPlutus.hs
@@ -10,24 +10,25 @@ module Spec.Plutus.Direct.TxInLockingPlutus
 
 import           Control.Applicative
 import           Control.Monad
-import           Control.Lens
-import           Data.Aeson (Value)
+import           Data.Aeson (FromJSON(..), Value, (.:))
 import           Data.Bool (not)
+import           Data.Eq
 import           Data.Function
+import           Data.Functor ((<&>))
+import           Data.HashMap.Lazy (HashMap)
 import           Data.Int
 import           Data.List ((!!))
 import           Data.Maybe
-import           Data.Monoid
-import           Data.String
+import           Data.Monoid (Last(..), (<>))
+import           Data.Text (Text)
 import           GHC.Real
 import           GHC.Num
 import           Hedgehog (Property, (===))
 import           Prelude (head)
 import           System.FilePath ((</>))
 import           Text.Show (Show(..))
 
-import qualified Control.Lens as CL
-import qualified Data.Aeson.Lens as CL
+import qualified Data.Aeson as J
 import qualified Data.List as L
 import qualified Data.HashMap.Lazy as HM
 import qualified Data.Text as T
@@ -45,6 +46,16 @@ import qualified Testnet.Conf as H
 {- HLINT ignore "Redundant return" -}
 {- HLINT ignore "Use let" -}
 
+data Utxo = Utxo
+  { address :: Text
+  , value :: HashMap Text Integer
+  } deriving (Eq, Show)
+
+instance FromJSON Utxo where
+  parseJSON = J.withObject "Coord" $ \v -> Utxo
+    <$> v .: "address"
+    <*> v .: "value"
+
 hprop_plutus :: Property
 hprop_plutus = H.integration . H.runFinallies . H.workspace "chairman" $ \tempAbsBasePath' -> do
   projectBase <- H.note =<< H.noteIO . IO.canonicalizePath =<< H.getProjectBase
@@ -109,15 +120,16 @@ hprop_plutus = H.integration . H.runFinallies . H.workspace "chairman" $ \tempAb
   H.cat $ work </> "utxo-1.json"
 
   utxo1Json <- H.leftFailM . H.readJsonFile $ work </> "utxo-1.json"
-  txin <- H.noteShow $ utxo1Json ^. CL._Object . CL.to HM.keys . CL.ix 0 . to T.unpack
-  lovelaceAtTxin <- H.nothingFailM . H.noteShow $ utxo1Json ^? CL.key (T.pack txin) . CL.key "value" . CL.key "lovelace" . CL._Integer
+  utxo1 <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(HashMap Text Utxo) utxo1Json
+  txin <- H.noteShow $ head $ HM.keys utxo1
+  lovelaceAtTxin <- H.nothingFailM . H.noteShow $ utxo1 & HM.lookup txin <&> value >>= HM.lookup "lovelace"
   lovelaceAtTxinDiv2 <- H.noteShow $ lovelaceAtTxin `div` 2
 
   void $ H.execCli
     [ "transaction", "build-raw"
     , "--alonzo-era"
     , "--fee", "0"
-    , "--tx-in", txin
+    , "--tx-in", T.unpack txin
     , "--tx-out", plutusScriptAddr <> "+" <> show @Integer lovelaceAtTxinDiv2
     , "--tx-out-datum-hash", scriptDatumHash
     , "--tx-out", utxoAddr <> "+" <> show @Integer lovelaceAtTxinDiv2
@@ -153,8 +165,8 @@ hprop_plutus = H.integration . H.runFinallies . H.workspace "chairman" $ \tempAb
   H.cat $ work </> "plutusutxo.json"
 
   plutusUtxoJson <- H.leftFailM . H.readJsonFile $ work </> "plutusutxo.json"
-
-  plutusUtxoTxIn <- H.noteShow $ plutusUtxoJson ^. CL._Object . CL.to HM.keys . CL.ix 0 . to T.unpack
+  plutusUtxo <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(HashMap Text Utxo) plutusUtxoJson
+  plutusUtxoTxIn <- H.noteShow $ head $ HM.keys plutusUtxo
 
   void $ H.execCli' execConfig
     [ "query", "utxo"
@@ -167,8 +179,8 @@ hprop_plutus = H.integration . H.runFinallies . H.workspace "chairman" $ \tempAb
   H.cat $ work </> "utxo-2.json"
 
   utxo2Json :: Value <- H.leftFailM $ H.readJsonFile $ work </> "utxo-2.json"
-
-  txinCollateral <- H.noteShow $ utxo2Json ^. CL._Object . CL.to HM.keys . CL.ix 0 . to T.unpack
+  utxo2 <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(HashMap Text Utxo) utxo2Json
+  txinCollateral <- H.noteShow $ head $ HM.keys utxo2
 
   void $ H.execCli' execConfig
     [ "query", "protocol-parameters"
@@ -178,7 +190,7 @@ hprop_plutus = H.integration . H.runFinallies . H.workspace "chairman" $ \tempAb
 
   let dummyaddress = "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4"
 
-  lovelaceAtplutusScriptAddr <- H.nothingFailM . H.noteShow $ plutusUtxoJson ^? CL.key (T.pack plutusUtxoTxIn) . CL.key "value" . CL.key "lovelace" . CL._Integer
+  lovelaceAtplutusScriptAddr <- H.nothingFailM . H.noteShow $ plutusUtxo & HM.lookup plutusUtxoTxIn <&> value >>= HM.lookup "lovelace"
 
   txFee <- H.noteShow $ plutusRequiredTime + plutusRequiredSpace
   spendable <- H.noteShow $ lovelaceAtplutusScriptAddr - plutusRequiredTime - plutusRequiredSpace
@@ -187,8 +199,8 @@ hprop_plutus = H.integration . H.runFinallies . H.workspace "chairman" $ \tempAb
     [ "transaction", "build-raw"
     , "--alonzo-era"
     , "--fee", show @Integer txFee
-    , "--tx-in", plutusUtxoTxIn
-    , "--tx-in-collateral", txinCollateral
+    , "--tx-in", T.unpack plutusUtxoTxIn
+    , "--tx-in-collateral", T.unpack txinCollateral
     , "--tx-out", dummyaddress <> "+" <> show @Integer spendable
     , "--tx-in-script-file", plutusScriptFileInUse
     , "--tx-in-datum-file", datumFile