diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Script/Read/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Script/Read/Common.hs new file mode 100644 index 0000000000..20fd0aad43 --- /dev/null +++ b/cardano-cli/src/Cardano/CLI/EraBased/Script/Read/Common.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} + +module Cardano.CLI.EraBased.Script.Read.Common + ( -- * Plutus Script Related + readScriptDataOrFile + , readScriptDatumOrFile + , readScriptRedeemerOrFile + , readFilePlutusScript + + -- * Simple Script Related + , readFileSimpleScript + ) +where + +import Cardano.Api as Api + +import Cardano.CLI.EraBased.Script.Types +import Cardano.CLI.Types.Common +import Cardano.CLI.Types.Errors.PlutusScriptDecodeError +import Cardano.CLI.Types.Errors.ScriptDataError +import Cardano.CLI.Types.Errors.ScriptDecodeError + + +import Prelude + +import qualified Data.Aeson as Aeson +import Data.Bifunctor +import qualified Data.ByteString as BS + +import qualified Data.ByteString.Lazy.Char8 as LBS + +import qualified Data.Text as Text + + +deserialisePlutusScript + :: BS.ByteString + -> Either PlutusScriptDecodeError AnyPlutusScript +deserialisePlutusScript bs = do + te <- first PlutusScriptJsonDecodeError $ deserialiseFromJSON AsTextEnvelope bs + case teType te of + TextEnvelopeType s -> case s of + sVer@"PlutusScriptV1" -> deserialiseAnyPlutusScriptVersion sVer PlutusScriptV1 te + sVer@"PlutusScriptV2" -> deserialiseAnyPlutusScriptVersion sVer PlutusScriptV2 te + sVer@"PlutusScriptV3" -> deserialiseAnyPlutusScriptVersion sVer PlutusScriptV3 te + unknownScriptVersion -> + Left . PlutusScriptDecodeErrorUnknownVersion $ Text.pack unknownScriptVersion + where + deserialiseAnyPlutusScriptVersion + :: IsPlutusScriptLanguage lang + => String + -> PlutusScriptVersion lang + -> TextEnvelope + -> Either PlutusScriptDecodeError AnyPlutusScript + deserialiseAnyPlutusScriptVersion v lang tEnv = + if v == show lang + then + first PlutusScriptDecodeTextEnvelopeError $ + deserialiseFromTextEnvelopeAnyOf [teTypes (AnyPlutusScriptVersion lang)] tEnv + else Left $ PlutusScriptDecodeErrorVersionMismatch (Text.pack v) (AnyPlutusScriptVersion lang) + + teTypes :: AnyPlutusScriptVersion -> FromSomeType HasTextEnvelope AnyPlutusScript + teTypes = + \case + AnyPlutusScriptVersion PlutusScriptV1 -> + FromSomeType (AsPlutusScript AsPlutusScriptV1) (AnyPlutusScript PlutusScriptV1) + AnyPlutusScriptVersion PlutusScriptV2 -> + FromSomeType (AsPlutusScript AsPlutusScriptV2) (AnyPlutusScript PlutusScriptV2) + AnyPlutusScriptVersion PlutusScriptV3 -> + FromSomeType (AsPlutusScript AsPlutusScriptV3) (AnyPlutusScript PlutusScriptV3) + +deserialiseSimpleScript + :: BS.ByteString + -> Either ScriptDecodeError (Script SimpleScript') +deserialiseSimpleScript bs = + case deserialiseFromJSON AsTextEnvelope bs of + Left _ -> + -- In addition to the TextEnvelope format, we also try to + -- deserialize the JSON representation of SimpleScripts. + case Aeson.eitherDecodeStrict' bs of + Left err -> Left (ScriptDecodeSimpleScriptError $ JsonDecodeError err) + Right script -> Right $ SimpleScript script + Right te -> + case deserialiseFromTextEnvelopeAnyOf [teType'] te of + Left err -> Left (ScriptDecodeTextEnvelopeError err) + Right script -> Right script + where + teType' :: FromSomeType HasTextEnvelope (Script SimpleScript') + teType' = FromSomeType (AsScript AsSimpleScript) id + +readFilePlutusScript + :: MonadIOTransError (FileError PlutusScriptDecodeError) t m + => FilePath + -> t m AnyPlutusScript +readFilePlutusScript plutusScriptFp = do + bs <- + handleIOExceptionsLiftWith (FileIOError plutusScriptFp) . liftIO $ + BS.readFile plutusScriptFp + modifyError (FileError plutusScriptFp) $ + hoistEither $ + deserialisePlutusScript bs + +readFileSimpleScript + :: MonadIOTransError (FileError ScriptDecodeError) t m + => FilePath + -> t m (Script SimpleScript') +readFileSimpleScript file = do + scriptBytes <- handleIOExceptionsLiftWith (FileIOError file) . liftIO $ BS.readFile file + modifyError (FileError file) $ + hoistEither $ + deserialiseSimpleScript scriptBytes + +readScriptDataOrFile + :: MonadIO m + => ScriptDataOrFile + -> ExceptT ScriptDataError m HashableScriptData +readScriptDataOrFile (ScriptDataValue d) = return d +readScriptDataOrFile (ScriptDataJsonFile fp) = do + sDataBs <- handleIOExceptT (ScriptDataErrorFile . FileIOError fp) $ LBS.readFile fp + sDataValue <- hoistEither . first (ScriptDataErrorJsonParse fp) $ Aeson.eitherDecode sDataBs + hoistEither + . first ScriptDataErrorJsonBytes + $ scriptDataJsonToHashable ScriptDataJsonDetailedSchema sDataValue +readScriptDataOrFile (ScriptDataCborFile fp) = do + origBs <- handleIOExceptT (ScriptDataErrorFile . FileIOError fp) (BS.readFile fp) + hSd <- + firstExceptT (ScriptDataErrorMetadataDecode fp) $ + hoistEither $ + deserialiseFromCBOR AsHashableScriptData origBs + firstExceptT (ScriptDataErrorValidation fp) $ + hoistEither $ + validateScriptData $ + getScriptData hSd + return hSd + +readScriptDatumOrFile + :: ScriptDatumOrFile witctx + -> ExceptT ScriptDataError IO (ScriptDatum witctx) +readScriptDatumOrFile (ScriptDatumOrFileForTxIn Nothing) = pure $ ScriptDatumForTxIn Nothing +readScriptDatumOrFile (ScriptDatumOrFileForTxIn (Just df)) = + ScriptDatumForTxIn . Just + <$> readScriptDataOrFile df +readScriptDatumOrFile InlineDatumPresentAtTxIn = pure InlineScriptDatum +readScriptDatumOrFile NoScriptDatumOrFileForMint = pure NoScriptDatumForMint +readScriptDatumOrFile NoScriptDatumOrFileForStake = pure NoScriptDatumForStake + +readScriptRedeemerOrFile + :: ScriptRedeemerOrFile + -> ExceptT ScriptDataError IO ScriptRedeemer +readScriptRedeemerOrFile = readScriptDataOrFile