{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.CLI.Compatible.Read
  ( readFilePlutusScript
  , readFileSimpleScript
  )
where

import Cardano.Api as Api
import Cardano.Api.Experimental.Plutus qualified as Exp

import Cardano.CLI.Compatible.Exception
import Cardano.CLI.Read (readFileCli)
import Cardano.CLI.Type.Error.ScriptDecodeError

import Prelude

import Data.Aeson qualified as Aeson
import Data.ByteString qualified as BS
import Data.Text qualified as Text

readFileSimpleScript
  :: FilePath
  -> CIO e (Script SimpleScript')
readFileSimpleScript :: forall e. FilePath -> CIO e (Script SimpleScript')
readFileSimpleScript FilePath
file = do
  scriptBytes <- FilePath -> RIO e ByteString
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FilePath -> m ByteString
readFileCli FilePath
file
  fromEitherCli $
    deserialiseSimpleScript scriptBytes

deserialiseSimpleScript
  :: BS.ByteString
  -> Either ScriptDecodeError (Script SimpleScript')
deserialiseSimpleScript :: ByteString -> Either ScriptDecodeError (Script SimpleScript')
deserialiseSimpleScript ByteString
bs =
  case ByteString -> Either JsonDecodeError TextEnvelope
forall a. FromJSON a => ByteString -> Either JsonDecodeError a
deserialiseFromJSON ByteString
bs of
    Left JsonDecodeError
_ ->
      -- In addition to the TextEnvelope format, we also try to
      -- deserialize the JSON representation of SimpleScripts.
      case ByteString -> Either FilePath SimpleScript
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict' ByteString
bs of
        Left FilePath
err -> ScriptDecodeError
-> Either ScriptDecodeError (Script SimpleScript')
forall a b. a -> Either a b
Left (JsonDecodeError -> ScriptDecodeError
ScriptDecodeSimpleScriptError (JsonDecodeError -> ScriptDecodeError)
-> JsonDecodeError -> ScriptDecodeError
forall a b. (a -> b) -> a -> b
$ FilePath -> JsonDecodeError
JsonDecodeError FilePath
err)
        Right SimpleScript
script -> Script SimpleScript'
-> Either ScriptDecodeError (Script SimpleScript')
forall a b. b -> Either a b
Right (Script SimpleScript'
 -> Either ScriptDecodeError (Script SimpleScript'))
-> Script SimpleScript'
-> Either ScriptDecodeError (Script SimpleScript')
forall a b. (a -> b) -> a -> b
$ SimpleScript -> Script SimpleScript'
SimpleScript SimpleScript
script
    Right TextEnvelope
te ->
      case [FromSomeType HasTextEnvelope (Script SimpleScript')]
-> TextEnvelope -> Either TextEnvelopeError (Script SimpleScript')
forall b.
[FromSomeType HasTextEnvelope b]
-> TextEnvelope -> Either TextEnvelopeError b
deserialiseFromTextEnvelopeAnyOf [FromSomeType HasTextEnvelope (Script SimpleScript')
teType'] TextEnvelope
te of
        Left TextEnvelopeError
err -> ScriptDecodeError
-> Either ScriptDecodeError (Script SimpleScript')
forall a b. a -> Either a b
Left (TextEnvelopeError -> ScriptDecodeError
ScriptDecodeTextEnvelopeError TextEnvelopeError
err)
        Right Script SimpleScript'
script -> Script SimpleScript'
-> Either ScriptDecodeError (Script SimpleScript')
forall a b. b -> Either a b
Right Script SimpleScript'
script
 where
  teType' :: FromSomeType HasTextEnvelope (Script SimpleScript')
  teType' :: FromSomeType HasTextEnvelope (Script SimpleScript')
teType' = AsType (Script SimpleScript')
-> (Script SimpleScript' -> Script SimpleScript')
-> FromSomeType HasTextEnvelope (Script SimpleScript')
forall (c :: * -> Constraint) a b.
c a =>
AsType a -> (a -> b) -> FromSomeType c b
FromSomeType (AsType SimpleScript' -> AsType (Script SimpleScript')
forall lang. AsType lang -> AsType (Script lang)
AsScript AsType SimpleScript'
AsSimpleScript) Script SimpleScript' -> Script SimpleScript'
forall a. a -> a
id

readFilePlutusScript
  :: forall era e
   . ShelleyBasedEra era
  -> FilePath
  -> CIO e (Exp.AnyPlutusScript (ShelleyLedgerEra era))
readFilePlutusScript :: forall era e.
ShelleyBasedEra era
-> FilePath -> CIO e (AnyPlutusScript (ShelleyLedgerEra era))
readFilePlutusScript ShelleyBasedEra era
sbe FilePath
plutusScriptFp = do
  bs <- FilePath -> RIO e ByteString
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FilePath -> m ByteString
readFileCli FilePath
plutusScriptFp
  te <- fromEitherCli $ deserialiseFromJSON bs
  let scriptBs = TextEnvelope -> ByteString
teRawCBOR TextEnvelope
te
      TextEnvelopeType anyScriptType = teType te
  case Exp.textToPlutusLanguage (Text.pack anyScriptType) of
    Just AnyPlutusScriptLanguage
lang ->
      Either DecoderError (AnyPlutusScript (ShelleyLedgerEra era))
-> RIO e (AnyPlutusScript (ShelleyLedgerEra era))
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
Either e a -> m a
fromEitherCli
        ( ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era =>
    Either DecoderError (AnyPlutusScript (ShelleyLedgerEra era)))
-> Either DecoderError (AnyPlutusScript (ShelleyLedgerEra era))
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe (ByteString
-> AnyPlutusScriptLanguage
-> Either DecoderError (AnyPlutusScript (ShelleyLedgerEra era))
forall era.
Era era =>
ByteString
-> AnyPlutusScriptLanguage
-> Either DecoderError (AnyPlutusScript era)
Exp.decodeAnyPlutusScript ByteString
scriptBs AnyPlutusScriptLanguage
lang)
            :: Either DecoderError (Exp.AnyPlutusScript (ShelleyLedgerEra era))
        )
    Maybe AnyPlutusScriptLanguage
Nothing ->
      FilePath -> RIO e (AnyPlutusScript (ShelleyLedgerEra era))
forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError (FilePath -> RIO e (AnyPlutusScript (ShelleyLedgerEra era)))
-> FilePath -> RIO e (AnyPlutusScript (ShelleyLedgerEra era))
forall a b. (a -> b) -> a -> b
$ FilePath
"Unsupported script language: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
anyScriptType