Convert to not use lenses

IntersectMBO · Jul 8, 2021 · 8f51076 · 8f51076
1 parent cbab29c
commit 8f51076
Show file tree

Hide file tree

Showing 4 changed files with 37 additions and 36 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: 0f411zwlraqrp3f68vmif80kqdw18ddr0lqc9bfq83mv277gcb4k
 
 source-repository-package
   type: git

diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal
@@ -101,15 +101,12 @@ test-suite cardano-testnet-tests
                       , hedgehog
                       , hedgehog-extras
                       , filepath
-                      , lens
-                      , lens-aeson
                       , tasty
                       , tasty-hedgehog
                       , text
                       , unordered-containers
 
-  other-modules:        Spec.Extras
-                        Spec.Plutus.Direct.TxInLockingPlutus
+  other-modules:        Spec.Plutus.Direct.TxInLockingPlutus
                         Spec.Plutus.Script.TxInLockingPlutus
 
   ghc-options:          -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T

diff --git a/cardano-testnet/test/Spec/Extras.hs b/cardano-testnet/test/Spec/Extras.hs
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
@@ -42,18 +43,27 @@ import qualified Test.Process as H
 import qualified Testnet.Cardano as H
 import qualified Testnet.Conf as H
 
+{- HLINT ignore "Redundant <&>" -}
 {- 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 "Utxo" $ \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
   conf@H.Conf { H.tempBaseAbsPath, H.tempAbsPath } <- H.noteShowM $ H.mkConf tempAbsBasePath' Nothing
 
   H.TestnetRuntime { H.bftSprockets, H.testnetMagic } <- H.testnet H.defaultTestnetOptions conf
 
-  -- path <- H.noteIO $ fromMaybe "" <$> IO.lookupEnv "PATH"
-
   execConfig <- H.noteShow H.ExecConfig
         { H.execConfigEnv = Last $ Just
           [ ("CARDANO_NODE_SOCKET_PATH", IO.sprocketArgumentName (head bftSprockets))
@@ -66,14 +76,13 @@ hprop_plutus = H.integration . H.runFinallies . H.workspace "chairman" $ \tempAb
   utxoVKeyFile <- H.note $ tempAbsPath </> "shelley/utxo-keys/utxo1.vkey"
   utxoSKeyFile <- H.note $ tempAbsPath </> "shelley/utxo-keys/utxo1.skey"
 
-  -- ("CARDANO_NODE_SOCKET_PATH", IO.sprocketArgumentName (head bftSprockets))
-
   plutusScriptFileInUse <- H.note $ base </> "scripts/plutus/scripts/untyped-always-succeeds-txin.plutus"
 
   -- This datum hash is the hash of the untyped 42
-  scriptDatumHash <- pure "9e1199a988ba72ffd6e9c269cadb3b53b5f360ff99f112d9b2ee30c4d74ad88b"
-  plutusRequiredSpace <- pure @_ @Integer 70000000
-  plutusRequiredTime <- pure @_ @Integer 70000000
+  let scriptDatumHash = "9e1199a988ba72ffd6e9c269cadb3b53b5f360ff99f112d9b2ee30c4d74ad88b"
+  let plutusRequiredSpace = id @Integer 70000000
+  let plutusRequiredTime = id @Integer 70000000
+
   datumFile <- H.note $ base </> "scripts/plutus/data/42.datum"
   redeemerFile <- H.note $ base </> "scripts/plutus/data/42.redeemer"
 
@@ -90,8 +99,6 @@ hprop_plutus = H.integration . H.runFinallies . H.workspace "chairman" $ \tempAb
     , "--testnet-magic", show @Int testnetMagic
     ]
 
-  -- mkdir -p $WORK
-
   utxoAddr <- H.execCli
     [ "address", "build"
     , "--testnet-magic", show @Int testnetMagic
@@ -109,15 +116,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
@@ -140,8 +148,7 @@ hprop_plutus = H.integration . H.runFinallies . H.workspace "chairman" $ \tempAb
 
   H.threadDelay 5000000
 
-  -- After "locking" the tx output at the script address, we can now can attempt to spend
-  -- the "locked" tx output below.
+  -- With the tx ouput at the script address we can now attempt to spend it.
 
   void $ H.execCli' execConfig
     [ "query", "utxo"
@@ -153,8 +160,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 +174,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 +185,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 +194,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