Last refactors

IntersectMBO · Jun 27, 2022 · bb288f7 · bb288f7
1 parent 3ac0b6f
commit bb288f7
Show file tree

Hide file tree

Showing 3 changed files with 47 additions and 51 deletions.
diff --git a/plutus-contract/src/Plutus/Contract/StateMachine.hs b/plutus-contract/src/Plutus/Contract/StateMachine.hs
@@ -55,6 +55,7 @@ module Plutus.Contract.StateMachine(
 import Control.Lens (_Right, makeClassyPrisms, review, (^?))
 import Control.Monad (unless)
 import Control.Monad.Error.Lens
+import Control.Monad.Except (throwError)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Either (rights)
 import Data.Map (Map)
@@ -137,16 +138,12 @@ getStates
     -> Map Tx.TxOutRef Tx.ChainIndexTxOut
     -> [OnChainState s i]
 getStates (SM.StateMachineInstance _ si) refMap =
-    -- FIXME refactor
-    let txOutRefLookup txOutRef = do
-          ciTxOut <- Map.lookup txOutRef refMap
-          datum <- ciTxOut ^? Tx.ciTxOutDatum . _Right
-          pure (Tx.toTxOut ciTxOut, datum)
-        lkp (ref, _out) = do
-            ocsTxOutRef <- Typed.typeScriptTxOutRef txOutRefLookup si ref
-            let ocsTxOut = Typed.tyTxOutRefOut ocsTxOutRef
-            pure OnChainState{ocsTxOut, ocsTxOutRef}
-    in rights $ fmap lkp $ Map.toList refMap
+    rights $ flip map (Map.toList refMap) $ \(txOutRef, ciTxOut) -> do
+      let txOut = Tx.toTxOut ciTxOut
+      datum <- maybe (throwError Typed.UnknownRef) pure $ ciTxOut ^? Tx.ciTxOutDatum . _Right
+      ocsTxOutRef <- Typed.typeScriptTxOutRef si txOutRef txOut datum
+      let ocsTxOut = Typed.tyTxOutRefOut ocsTxOutRef
+      pure OnChainState{ocsTxOut, ocsTxOutRef}
 
 -- | An invalid transition
 data InvalidTransition s i =

diff --git a/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs b/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs
@@ -99,7 +99,8 @@ import Ledger.Tx (ChainIndexTxOut, RedeemerPtr (RedeemerPtr), ScriptTag (Mint),
                   TxOut (txOutAddress, txOutDatumHash, txOutValue), TxOutRef)
 import Ledger.Tx qualified as Tx
 import Ledger.Tx.CardanoAPI qualified as C
-import Ledger.Typed.Scripts (Any, TypedValidator, ValidatorTypes (DatumType, RedeemerType))
+import Ledger.Typed.Scripts (Any, ConnectionError (UnknownRef), TypedValidator,
+                             ValidatorTypes (DatumType, RedeemerType))
 import Ledger.Typed.Scripts qualified as Scripts
 import Ledger.Validation (evaluateMinLovelaceOutput, fromPlutusTxOutUnsafe)
 import Plutus.Script.Utils.V1.Scripts (datumHash, mintingPolicyHash, validatorHash)
@@ -491,14 +492,15 @@ addOwnInput
 addOwnInput ScriptInputConstraint{icRedeemer, icTxOutRef} = do
     ScriptLookups{slTxOutputs, slTypedValidator} <- ask
     inst <- maybe (throwError TypedValidatorMissing) pure slTypedValidator
-    let txOutRefLookup txOutRef = do
-          ciTxOut <- Map.lookup txOutRef slTxOutputs
-          datum <- ciTxOut ^? Tx.ciTxOutDatum . _Right
-          pure (Tx.toTxOut ciTxOut, datum)
     typedOutRef <-
-        either (throwError . TypeCheckFailed) pure
-        $ runExcept @Typed.ConnectionError
-        $ Typed.typeScriptTxOutRef txOutRefLookup inst icTxOutRef
+      either (throwError . TypeCheckFailed) pure
+      $ runExcept @Typed.ConnectionError
+      $ do
+          (txOut, datum) <- maybe (throwError UnknownRef) pure $ do
+                                ciTxOut <- Map.lookup icTxOutRef slTxOutputs
+                                datum <- ciTxOut ^? Tx.ciTxOutDatum . _Right
+                                pure (Tx.toTxOut ciTxOut, datum)
+          Typed.typeScriptTxOutRef inst icTxOutRef txOut datum
     let txIn = Typed.makeTypedScriptTxIn inst icRedeemer typedOutRef
         vl   = Tx.txOutValue $ Typed.tyTxOutTxOut $ Typed.tyTxOutRefOut typedOutRef
     unbalancedTx . tx . Tx.inputs %= Set.insert (Typed.tyTxInTxIn txIn)

diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V1/Typed/Scripts.hs b/plutus-script-utils/src/Plutus/Script/Utils/V1/Typed/Scripts.hs
@@ -28,7 +28,6 @@ module Plutus.Script.Utils.V1.Typed.Scripts
   )
 where
 
-import Control.Monad (unless)
 import Control.Monad.Except (MonadError (throwError))
 import Data.Aeson (FromJSON (parseJSON), KeyValue ((.=)), ToJSON (toJSON), object, (.:))
 import Data.Aeson qualified
@@ -42,7 +41,7 @@ import Plutus.V1.Ledger.Api (Credential (PubKeyCredential, ScriptCredential), Da
                              Redeemer (Redeemer), StakeValidator, ToData (..),
                              TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue), TxOutRef, Validator, Value,
                              addressCredential)
-import Plutus.V1.Ledger.Tx (TxIn (TxIn, txInType), TxInType (ConsumePublicKeyAddress, ConsumeScriptAddress))
+import Plutus.V1.Ledger.Tx (TxIn (TxIn, txInRef, txInType), TxInType (ConsumePublicKeyAddress, ConsumeScriptAddress))
 
 {- Note [Scripts returning Bool]
 It used to be that the signal for validation failure was a script being `error`. This is nice for
@@ -175,9 +174,9 @@ typePubKeyTxIn ::
   (MonadError ConnectionError m) =>
   TxIn ->
   m PubKeyTxIn
-typePubKeyTxIn inn@TxIn {txInType} =
-  case txInType of
-    Just ConsumePublicKeyAddress -> pure $ PubKeyTxIn inn
+typePubKeyTxIn txIn =
+  case txInType txIn of
+    Just ConsumePublicKeyAddress -> pure $ PubKeyTxIn txIn
     Just x                       -> throwError $ WrongInType x
     Nothing                      -> throwError MissingInType
 
@@ -187,9 +186,9 @@ typePubKeyTxOut ::
   (MonadError ConnectionError m) =>
   TxOut ->
   m PubKeyTxOut
-typePubKeyTxOut out@TxOut {txOutDatumHash} =
-  case txOutDatumHash of
-    Nothing -> pure $ PubKeyTxOut out
+typePubKeyTxOut txOut =
+  case txOutDatumHash txOut of
+    Nothing -> pure $ PubKeyTxOut txOut
     Just _  -> throwError $ WrongOutType ExpectedPubkeyGotScript
 
 -- | Create a 'TypedScriptTxIn' from an existing 'TxIn' by checking the types of its parts.
@@ -205,16 +204,19 @@ typeScriptTxIn ::
   TypedValidator inn ->
   TxIn ->
   m (TypedScriptTxIn inn)
-typeScriptTxIn _lookupRef _typedValidator (TxIn _tor Nothing) =
-  throwError MissingInType
-typeScriptTxIn lookupRef typedValidator (TxIn tor (Just tit)) =
-  case tit of
-    ConsumeScriptAddress _val re da -> do
+typeScriptTxIn lookupRef typedValidator txIn =
+  case txInType txIn of
+    Just (ConsumeScriptAddress _val re da) -> do
       rsVal <- checkRedeemer typedValidator re
       _ <- checkDatum typedValidator da
-      typedOut <- typeScriptTxOutRef @inn lookupRef typedValidator tor
-      pure $ makeTypedScriptTxIn typedValidator rsVal typedOut
-    _ -> throwError $ WrongInType tit
+      let txOutRef = txInRef txIn
+      case lookupRef txOutRef of
+        Just (txOut, datum) -> do
+          typedOut <- typeScriptTxOutRef @inn typedValidator txOutRef txOut datum
+          pure $ makeTypedScriptTxIn typedValidator rsVal typedOut
+        Nothing -> throwError UnknownRef
+    Just tit -> throwError $ WrongInType tit
+    Nothing -> throwError MissingInType
 
 -- | Create a 'TypedScriptTxOut' from an existing 'TxOut' by checking the types of its parts.
 typeScriptTxOut ::
@@ -224,22 +226,21 @@ typeScriptTxOut ::
     MonadError ConnectionError m
   ) =>
   TypedValidator out ->
+  TxOutRef ->
   TxOut ->
   Datum ->
   m (TypedScriptTxOut out)
-typeScriptTxOut tv txOut@TxOut {txOutAddress, txOutDatumHash} datum = do
-  case addressCredential txOutAddress of
+typeScriptTxOut tv txOutRef txOut datum = do
+  case addressCredential (txOutAddress txOut) of
     PubKeyCredential _ ->
       throwError $ WrongOutType ExpectedScriptGotPubkey
     ScriptCredential _vh ->
-      case txOutDatumHash of
-        Just dh -> do
-          unless (datumHash datum == dh) $
-            error "wrong datum hash" -- FIXME
-          checkValidatorAddress tv txOutAddress
+      case txOutDatumHash txOut of
+        Just dh | datumHash datum == dh -> do
+          checkValidatorAddress tv (txOutAddress txOut)
           dsVal <- checkDatum tv datum
           pure $ TypedScriptTxOut @out txOut dsVal
-        Nothing -> error "no datum hash" -- FIXME
+        _ -> throwError $ NoDatum txOutRef (datumHash datum)
 
 -- | Create a 'TypedScriptTxOut' from an existing 'TxOut' by checking the types of its parts. To do this we
 -- need to cross-reference against the validator script and be able to look up the 'TxOut' to which this
@@ -250,15 +251,11 @@ typeScriptTxOutRef ::
     ToData (DatumType out),
     MonadError ConnectionError m
   ) =>
-  (TxOutRef -> Maybe (TxOut, Datum)) ->
   TypedValidator out ->
   TxOutRef ->
+  TxOut ->
+  Datum ->
   m (TypedScriptTxOutRef out)
-typeScriptTxOutRef lookupRef ct ref = do
-  -- FIXME, this function feels silly to me
-  case lookupRef ref of
-    Just (txOut, datum) -> do
-      tyOut <- typeScriptTxOut @out ct txOut datum
-      pure $ TypedScriptTxOutRef ref tyOut
-    Nothing ->
-      throwError UnknownRef
+typeScriptTxOutRef tv txOutRef txOut datum = do
+  tyOut <- typeScriptTxOut tv txOutRef txOut datum
+  pure $ TypedScriptTxOutRef txOutRef tyOut