Use MonadThrow in partial functions

Author: palas

cardano-wasm/cardano-wasm.cabal

@@ -55,6 +55,7 @@ executable cardano-wasm
     cardano-strict-containers,
     cborg,
     containers,
+    exceptions,
     microlens,
     text,
 

cardano-wasm/src/Cardano/Wasm/Api/Tx.hs

@@ -22,6 +22,7 @@ import Cardano.Ledger.Binary (Annotator, DecCBOR (decCBOR), EncCBOR, Version, de
 import Cardano.Wasm.Internal.ExceptionHandling (justOrError, rightOrError)
 
 import Codec.CBOR.Write qualified as CBOR
+import Control.Monad.Catch (Exception (displayException), MonadThrow)
 import Data.Aeson (ToJSON (toJSON), (.=))
 import Data.Aeson qualified as Aeson
 import Data.Aeson.Types qualified as Aeson
@@ -64,15 +65,17 @@ instance FromJSON UnsignedTxObject where
   parseJSON :: HasCallStack => Aeson.Value -> Aeson.Parser UnsignedTxObject
   parseJSON = Aeson.withObject "UnsignedTxObject" $ \o -> do
     Exp.Some era <- o Aeson..: "era"
-    let decode :: forall a. DecCBOR (Annotator a) => Text.Text -> Text.Text -> a
+    let decode :: forall m a. (MonadThrow m, DecCBOR (Annotator a)) => Text.Text -> Text.Text -> m a
         decode desc cbor = do
-          let cddlBS = rightOrError $ Base16.decode $ Text.encodeUtf8 cbor
+          cddlBS <- rightOrError $ Base16.decode $ Text.encodeUtf8 cbor
           rightOrError $ decodeFullAnnotator (eraToVersion era) desc decCBOR (fromStrict cddlBS)
     keyWitnesses :: [Text.Text] <- o Aeson..: "keyWitnesess"
     tx :: Text.Text <- o Aeson..: "tx"
-    obtainCommonConstraints era $
+    obtainCommonConstraints era $ do
+      decodedWitnesses <- mapM (toMonadFail . decode "KeyWitness") keyWitnesses
+      decodedTx <- toMonadFail $ decode "Tx" tx
       return $
-        UnsignedTxObject era (map (decode "KeyWitness") keyWitnesses) (Exp.UnsignedTx (decode "Tx" tx))
+        UnsignedTxObject era decodedWitnesses (Exp.UnsignedTx decodedTx)
 
 -- | Create a new unsigned transaction object for making a Conway era transaction.
 newConwayTxImpl :: UnsignedTxObject
@@ -88,11 +91,12 @@ addTxInputImpl (UnsignedTxObject era keyWitnesess (Exp.UnsignedTx tx)) txId txIx
 
 -- | Add a simple transaction output to an unsigned transaction object.
 -- It takes a destination address and an amount in lovelace.
-addSimpleTxOutImpl :: HasCallStack => UnsignedTxObject -> String -> Ledger.Coin -> UnsignedTxObject
+addSimpleTxOutImpl
+  :: (HasCallStack, MonadThrow m) => UnsignedTxObject -> String -> Ledger.Coin -> m UnsignedTxObject
 addSimpleTxOutImpl (UnsignedTxObject era keyWitnesess (Exp.UnsignedTx tx)) destAddr lovelaceAmount =
-  obtainCommonConstraints era $
-    let destAddress = deserialiseAddress era destAddr
-        sbe = Api.convert era
+  obtainCommonConstraints era $ do
+    destAddress <- deserialiseAddress era destAddr
+    let sbe = Api.convert era
         txOut =
           Api.TxOut
             destAddress
@@ -101,12 +105,11 @@ addSimpleTxOutImpl (UnsignedTxObject era keyWitnesess (Exp.UnsignedTx tx)) destA
             Shelley.ReferenceScriptNone
         shelleyTxOut = TxBody.toShelleyTxOutAny sbe txOut
         tx' = tx & Ledger.bodyTxL . Ledger.outputsTxBodyL %~ (<> StrictSeq.fromList [shelleyTxOut])
-     in UnsignedTxObject era keyWitnesess $ Exp.UnsignedTx tx'
+    return $ UnsignedTxObject era keyWitnesess $ Exp.UnsignedTx tx'
  where
   deserialiseAddress
-    :: HasCallStack
-    => Exp.EraCommonConstraints era
-    => Exp.Era era -> String -> Api.AddressInEra era
+    :: (HasCallStack, MonadThrow m, Exp.EraCommonConstraints era)
+    => Exp.Era era -> String -> m (Api.AddressInEra era)
   deserialiseAddress _eon destAddrStr =
     justOrError
       "Couldn't deserialise destination address"
@@ -155,14 +158,21 @@ instance FromJSON SignedTxObject where
   parseJSON :: HasCallStack => Aeson.Value -> Aeson.Parser SignedTxObject
   parseJSON = Aeson.withObject "SignedTxObject" $ \o -> do
     Exp.Some era <- o Aeson..: "era"
-    let decode :: forall a. DecCBOR (Annotator a) => Text.Text -> Text.Text -> a
+    let decode :: forall m a. (MonadThrow m, DecCBOR (Annotator a)) => Text.Text -> Text.Text -> m a
         decode desc cbor = do
-          let cddlBS = rightOrError $ Base16.decode $ Text.encodeUtf8 cbor
+          cddlBS <- rightOrError $ Base16.decode $ Text.encodeUtf8 cbor
           rightOrError $ decodeFullAnnotator (eraToVersion era) desc decCBOR (fromStrict cddlBS)
     tx :: Text.Text <- o Aeson..: "tx"
-    obtainCommonConstraints era $
+    obtainCommonConstraints era $ do
+      decodedTx <- toMonadFail $ decode "Tx" tx
       return $
-        SignedTxObject era (decode "Tx" tx)
+        SignedTxObject era decodedTx
+
+-- | Convert an 'Either' value to a 'MonadFail' monad. This can be useful for converting
+-- MonadThrow monads into Aeson Parser monads, but it loses the stack trace information.
+toMonadFail :: (Exception e, MonadFail m) => Either e a -> m a
+toMonadFail (Left e) = fail $ displayException e
+toMonadFail (Right a) = return a
 
 -- | Convert a signed transaction object to a base16 encoded string of its CBOR representation.
 toCborImpl :: SignedTxObject -> String

cardano-wasm/src/Cardano/Wasm/General/ExceptionHandling.hs

@@ -1,21 +1,23 @@
 module Cardano.Wasm.Internal.ExceptionHandling where
 
-import Control.Exception (Exception, throwIO)
+import Control.Exception (Exception)
+import Control.Monad.Catch (MonadThrow (..))
 import GHC.Stack (HasCallStack, withFrozenCallStack)
 
+newtype ExpectedJustException = ExpectedJustException String
+  deriving Show
+
+instance Exception ExpectedJustException
+
 newtype ExpectedRightException = ExpectedRightException String
   deriving Show
 
 instance Exception ExpectedRightException
 
-justOrError :: HasCallStack => String -> Maybe a -> a
-justOrError e Nothing = withFrozenCallStack $ error e
-justOrError _ (Just a) = a
-
-rightOrError :: (HasCallStack, Show e) => Either e a -> a
-rightOrError (Left e) = withFrozenCallStack $ error $ show e
-rightOrError (Right a) = a
+justOrError :: (HasCallStack, MonadThrow m) => String -> Maybe a -> m a
+justOrError e Nothing = withFrozenCallStack $ throwM $ ExpectedJustException e
+justOrError _ (Just a) = return a
 
-rightOrErrorM :: (HasCallStack, Show e) => Either e a -> IO a
-rightOrErrorM (Left e) = withFrozenCallStack $ throwIO $ ExpectedRightException (show e)
-rightOrErrorM (Right a) = return a
+rightOrError :: (HasCallStack, MonadThrow m, Show e) => Either e a -> m a
+rightOrError (Left e) = withFrozenCallStack $ throwM $ ExpectedRightException $ show e
+rightOrError (Right a) = return a

cardano-wasm/src/Cardano/Wasm/Internal/Api/Tx.hs

@@ -18,9 +18,10 @@ import Cardano.Api.Ledger qualified as Ledger
 
 import Cardano.Wasm.Internal.Api.Info (apiInfo)
 import Cardano.Wasm.Internal.Api.Tx qualified as Wasm
-import Cardano.Wasm.Internal.ExceptionHandling (rightOrErrorM)
+import Cardano.Wasm.Internal.ExceptionHandling (rightOrError)
 
 import Control.Exception (evaluate)
+import Control.Monad (join)
 import Data.Aeson qualified as Aeson
 import Data.ByteString.UTF8 (fromString, toString)
 import Data.Text (Text)
@@ -136,12 +137,12 @@ instance (Api.FromJSON a, Typeable a) => FromJSVal JSVal a where
 instance FromJSVal JSSigningKey (Api.SigningKey Api.PaymentKey) where
   fromJSVal :: HasCallStack => JSSigningKey -> IO (Api.SigningKey Api.PaymentKey)
   fromJSVal jsString = do
-    rightOrErrorM $ Api.deserialiseFromBech32 (Text.pack (fromJSString jsString))
+    rightOrError $ Api.deserialiseFromBech32 (Text.pack (fromJSString jsString))
 
 instance FromJSVal JSTxId Api.TxId where
   fromJSVal :: HasCallStack => JSTxId -> IO Api.TxId
   fromJSVal jsString = do
-    rightOrErrorM $ Api.deserialiseFromRawBytesHex (fromString (fromJSString jsString))
+    rightOrError $ Api.deserialiseFromRawBytesHex (fromString (fromJSString jsString))
 
 instance FromJSVal JSTxIx Api.TxIx where
   fromJSVal = return . Api.TxIx . fromIntegral
@@ -181,13 +182,14 @@ addTxInput jsUnsignedTx jsTxId jsTxIx =
 
 -- | Add a simple transaction output (address and lovelace amount) to an unsigned transaction.
 addSimpleTxOut :: JSUnsignedTx -> JSString -> JSCoin -> IO JSUnsignedTx
-addSimpleTxOut jsUnsignedTx jsDestAddr jsCoin = do
+addSimpleTxOut jsUnsignedTx jsDestAddr jsCoin =
   toJSVal
-    =<< ( Wasm.addSimpleTxOutImpl
-            <$> fromJSVal jsUnsignedTx
-            <*> fromJSVal jsDestAddr
-            <*> fromJSVal jsCoin
-        )
+    =<< join
+      ( Wasm.addSimpleTxOutImpl
+          <$> fromJSVal jsUnsignedTx
+          <*> fromJSVal jsDestAddr
+          <*> fromJSVal jsCoin
+      )
 
 -- | Set the transaction fee for an unsigned transaction.
 setFee :: JSUnsignedTx -> JSCoin -> IO JSUnsignedTx
@@ -210,7 +212,7 @@ addSigningKey jsUnsignedTx jsSigningKey =
 -- | Sign an unsigned transaction.
 signTx :: JSUnsignedTx -> IO JSSignedTx
 signTx jsUnsignedTx =
-  toJSVal =<< Wasm.signTxImpl <$> fromJSVal jsUnsignedTx
+  toJSVal . Wasm.signTxImpl =<< fromJSVal jsUnsignedTx
 
 -- *  SignedTxObject
 
@@ -220,7 +222,7 @@ foreign export javascript "txToCbor"
 -- | Convert a signed transaction to its CBOR representation (hex-encoded string).
 txToCbor :: JSSignedTx -> IO JSString
 txToCbor jsSignedTx =
-  toJSVal =<< Wasm.toCborImpl <$> fromJSVal jsSignedTx
+  toJSVal . Wasm.toCborImpl =<< fromJSVal jsSignedTx
 
 -- * API Information
 
@@ -230,4 +232,4 @@ foreign export javascript "getApiInfo"
 getApiInfo :: IO JSApiInfo
 getApiInfo = toJSVal apiInfo
 
-#endif
+#endif