Read.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Cardano.CLI.Run.Legacy.Read
  ( -- * Metadata
    MetadataError(..)
  , renderMetadataError
  , readFileTxMetadata
  , readTxMetadata

    -- * Script
  , ScriptWitnessError(..)
  , renderScriptWitnessError
  , readScriptDataOrFile
  , readScriptWitness
  , readScriptWitnessFiles
  , readScriptWitnessFilesThruple
  , ScriptDecodeError (..)
  , deserialiseScriptInAnyLang
  , readFileScriptInAnyLang

  -- * Script data (datums and redeemers)
  , ScriptDataError(..)
  , readScriptDatumOrFile
  , readScriptRedeemerOrFile
  , renderScriptDataError

  -- * Tx
  , CddlError(..)
  , CddlTx(..)
  , IncompleteTx(..)
  , readFileTx
  , readFileTxBody
  , readCddlTx -- For testing purposes

  -- * Tx witnesses
  , ReadWitnessSigningDataError(..)
  , renderReadWitnessSigningDataError
  , SomeWitness(..)
  , ByronOrShelleyWitness(..)
  , ShelleyBootstrapWitnessSigningKeyData(..)
  , CddlWitnessError(..)
  , readFileTxKeyWitness
  , readWitnessSigningData

  -- * Required signer
  , RequiredSignerError(..)
  , categoriseSomeWitness
  , readRequiredSigner

  -- * Governance related
  , ConstitutionError(..)
  , VoteError (..)
  , readTxNewConstitutionActions
  , readTxVotes

  -- * FileOrPipe
  , FileOrPipe
  , fileOrPipe
  , fileOrPipePath
  , fileOrPipeCache
  , readFileOrPipe
  ) where

import           Cardano.Api as Api
import           Cardano.Api.Shelley

import qualified Cardano.Binary as CBOR
import           Cardano.CLI.EraBased.Legacy
import           Cardano.CLI.Types.Governance
import           Cardano.CLI.Types.Legacy

import           Prelude

import           Control.Exception (bracket)
import           Control.Monad (forM, unless)
import           Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, left,
                   newExceptT)
import qualified Data.Aeson as Aeson
import           Data.Bifunctor (first)
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import           Data.IORef (IORef, newIORef, readIORef, writeIORef)
import qualified Data.List as List
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Word
import           GHC.IO.Handle (hClose, hIsSeekable)
import           GHC.IO.Handle.FD (openFileBlocking)
import           System.IO (IOMode (ReadMode))

-- Metadata

data MetadataError
  = MetadataErrorFile (FileError ())
  | MetadataErrorJsonParseError !FilePath !String
  | MetadataErrorConversionError !FilePath !TxMetadataJsonError
  | MetadataErrorValidationError !FilePath ![(Word64, TxMetadataRangeError)]
  | MetadataErrorDecodeError !FilePath !CBOR.DecoderError
  | MetadataErrorNotAvailableInEra AnyCardanoEra
  deriving Show

renderMetadataError :: MetadataError -> Text
renderMetadataError (MetadataErrorFile fileErr) =
  Text.pack $ displayError fileErr
renderMetadataError (MetadataErrorJsonParseError fp jsonErr) =
  Text.pack $ "Invalid JSON format in file: " <> show fp <>
              "\nJSON parse error: " <> jsonErr
renderMetadataError (MetadataErrorConversionError fp metadataErr) =
  Text.pack $ "Error reading metadata at: " <> show fp <>
              "\n" <> displayError metadataErr
renderMetadataError (MetadataErrorValidationError fp errs) =
  Text.pack $ "Error validating transaction metadata at: " <> fp <> "\n" <>
      List.intercalate "\n"
        [ "key " <> show k <> ":" <> displayError valErr
        | (k, valErr) <- errs ]
renderMetadataError (MetadataErrorDecodeError fp metadataErr) =
  Text.pack $ "Error decoding CBOR metadata at: " <> show fp <>
              " Error: " <> show metadataErr
renderMetadataError (MetadataErrorNotAvailableInEra e) =
  "Transaction metadata not supported in " <> renderEra e

readTxMetadata :: CardanoEra era
               -> TxMetadataJsonSchema
               -> [MetadataFile]
               -> IO (Either MetadataError (TxMetadataInEra era))
readTxMetadata _ _ [] = return $ Right TxMetadataNone
readTxMetadata era schema files =
  case txMetadataSupportedInEra era of
    Nothing ->
      return . Left
        . MetadataErrorNotAvailableInEra
        $ getIsCardanoEraConstraint era $ AnyCardanoEra era
    Just supported -> do
      let exceptAllTxMetadata = mapM (readFileTxMetadata schema) files
      eAllTxMetaData <- runExceptT exceptAllTxMetadata
      return $ do
        metaData <- eAllTxMetaData
        Right $ TxMetadataInEra supported $ mconcat metaData

readFileTxMetadata
  :: TxMetadataJsonSchema
  -> MetadataFile
  -> ExceptT MetadataError IO TxMetadata
readFileTxMetadata mapping (MetadataFileJSON fp) = do
  bs <- handleIOExceptT (MetadataErrorFile . FileIOError (unFile fp))
          $ LBS.readFile (unFile fp)
  v <- firstExceptT (MetadataErrorJsonParseError (unFile fp))
          $ hoistEither $ Aeson.eitherDecode' bs
  txMetadata' <- firstExceptT (MetadataErrorConversionError (unFile fp))
                  . hoistEither $ metadataFromJson mapping v
  firstExceptT (MetadataErrorValidationError (unFile fp))
    . hoistEither $ do
      validateTxMetadata txMetadata'
      return txMetadata'
readFileTxMetadata _ (MetadataFileCBOR fp) = do
  bs <- handleIOExceptT (MetadataErrorFile . FileIOError (unFile fp))
          $ BS.readFile (unFile fp)
  txMetadata' <- firstExceptT (MetadataErrorDecodeError (unFile fp))
                  . hoistEither $ deserialiseFromCBOR AsTxMetadata bs
  firstExceptT (MetadataErrorValidationError (unFile fp))
    . hoistEither $ do
      validateTxMetadata txMetadata'
      return txMetadata'

-- Script witnesses/ Scripts

data ScriptWitnessError
  = ScriptWitnessErrorFile (FileError ScriptDecodeError)
  | ScriptWitnessErrorScriptLanguageNotSupportedInEra AnyScriptLanguage AnyCardanoEra
  | ScriptWitnessErrorExpectedSimple !FilePath !AnyScriptLanguage
  | ScriptWitnessErrorExpectedPlutus !FilePath !AnyScriptLanguage
  | ScriptWitnessErrorReferenceScriptsNotSupportedInEra !AnyCardanoEra
  | ScriptWitnessErrorScriptData ScriptDataError

renderScriptWitnessError :: ScriptWitnessError -> Text
renderScriptWitnessError (ScriptWitnessErrorFile err) =
  Text.pack $ displayError err
renderScriptWitnessError (ScriptWitnessErrorScriptLanguageNotSupportedInEra (AnyScriptLanguage lang) anyEra) =
  "The script language " <> Text.pack (show lang) <> " is not supported in the " <>
  renderEra anyEra <> " era."
renderScriptWitnessError (ScriptWitnessErrorExpectedSimple file (AnyScriptLanguage lang)) =
  Text.pack $ file <> ": expected a script in the simple script language, " <>
  "but it is actually using " <> show lang <> ". Alternatively, to use " <>
  "a Plutus script, you must also specify the redeemer " <>
  "(datum if appropriate) and script execution units."
renderScriptWitnessError (ScriptWitnessErrorExpectedPlutus file (AnyScriptLanguage lang)) =
  Text.pack $ file <> ": expected a script in the Plutus script language, " <>
  "but it is actually using " <> show lang <> "."
renderScriptWitnessError (ScriptWitnessErrorReferenceScriptsNotSupportedInEra anyEra) =
  "Reference scripts not supported in era: " <> renderEra anyEra
renderScriptWitnessError (ScriptWitnessErrorScriptData sDataError) =
  renderScriptDataError sDataError

readScriptWitnessFiles
  :: CardanoEra era
  -> [(a, Maybe (ScriptWitnessFiles ctx))]
  -> ExceptT ScriptWitnessError IO [(a, Maybe (ScriptWitness ctx era))]
readScriptWitnessFiles era = mapM readSwitFile
 where
  readSwitFile (tIn, Just switFile) = do
      sWit <- readScriptWitness era switFile
      return (tIn, Just sWit)
  readSwitFile (tIn, Nothing) = return (tIn, Nothing)

readScriptWitnessFilesThruple
  :: CardanoEra era
  -> [(a, b, Maybe (ScriptWitnessFiles ctx))]
  -> ExceptT ScriptWitnessError IO [(a, b, Maybe (ScriptWitness ctx era))]
readScriptWitnessFilesThruple era = mapM readSwitFile
 where
  readSwitFile (tIn, b, Just switFile) = do
      sWit <- readScriptWitness era switFile
      return (tIn, b, Just sWit)
  readSwitFile (tIn, b, Nothing) = return (tIn, b, Nothing)

readScriptWitness
  :: CardanoEra era
  -> ScriptWitnessFiles witctx
  -> ExceptT ScriptWitnessError IO (ScriptWitness witctx era)
readScriptWitness era (SimpleScriptWitnessFile (ScriptFile scriptFile)) = do
    script@(ScriptInAnyLang lang _) <- firstExceptT ScriptWitnessErrorFile $
                                         readFileScriptInAnyLang scriptFile
    ScriptInEra langInEra script'   <- validateScriptSupportedInEra era script
    case script' of
      SimpleScript sscript ->
        return . SimpleScriptWitness langInEra $ SScript sscript

      -- If the supplied cli flags were for a simple script (i.e. the user did
      -- not supply the datum, redeemer or ex units), but the script file turns
      -- out to be a valid plutus script, then we must fail.
      PlutusScript{} ->
        left $ ScriptWitnessErrorExpectedSimple
                 scriptFile
                 (AnyScriptLanguage lang)

readScriptWitness era (PlutusScriptWitnessFiles
                          (ScriptFile scriptFile)
                          datumOrFile
                          redeemerOrFile
                          execUnits) = do
    script@(ScriptInAnyLang lang _) <- firstExceptT ScriptWitnessErrorFile $
                                         readFileScriptInAnyLang scriptFile
    ScriptInEra langInEra script'   <- validateScriptSupportedInEra era script
    case script' of
      PlutusScript version pscript -> do
        datum <- firstExceptT ScriptWitnessErrorScriptData
                   $ readScriptDatumOrFile    datumOrFile
        redeemer <- firstExceptT ScriptWitnessErrorScriptData
                      $ readScriptRedeemerOrFile redeemerOrFile
        return $ PlutusScriptWitness
                   langInEra version (PScript pscript)
                   datum
                   redeemer
                   execUnits

      -- If the supplied cli flags were for a plutus script (i.e. the user did
      -- supply the datum, redeemer and ex units), but the script file turns
      -- out to be a valid simple script, then we must fail.
      SimpleScript{} ->
        left $ ScriptWitnessErrorExpectedPlutus
                 scriptFile
                 (AnyScriptLanguage lang)

readScriptWitness era (PlutusReferenceScriptWitnessFiles refTxIn
                          anyScrLang@(AnyScriptLanguage anyScriptLanguage)
                          datumOrFile redeemerOrFile execUnits mPid) = do
  case refInsScriptsAndInlineDatsSupportedInEra era of
    Nothing -> left $ ScriptWitnessErrorReferenceScriptsNotSupportedInEra
                    $ getIsCardanoEraConstraint era (AnyCardanoEra era)
    Just _ -> do

      case scriptLanguageSupportedInEra era anyScriptLanguage of
        Just sLangInEra ->
          case languageOfScriptLanguageInEra sLangInEra of
            SimpleScriptLanguage ->
              -- TODO: We likely need another datatype eg data ReferenceScriptWitness lang
              -- in order to make this branch unrepresentable.
              error "readScriptWitness: Should not be possible to specify a simple script"
            PlutusScriptLanguage version -> do
              datum <- firstExceptT ScriptWitnessErrorScriptData
                         $ readScriptDatumOrFile    datumOrFile
              redeemer <- firstExceptT ScriptWitnessErrorScriptData
                            $ readScriptRedeemerOrFile redeemerOrFile
              return $ PlutusScriptWitness
                         sLangInEra
                         version
                         (PReferenceScript refTxIn (unPolicyId <$> mPid))
                         datum redeemer execUnits
        Nothing ->
          left $ ScriptWitnessErrorScriptLanguageNotSupportedInEra anyScrLang (anyCardanoEra era)
readScriptWitness era (SimpleReferenceScriptWitnessFiles refTxIn
                         anyScrLang@(AnyScriptLanguage anyScriptLanguage) mPid) = do
  case refInsScriptsAndInlineDatsSupportedInEra era of
    Nothing -> left $ ScriptWitnessErrorReferenceScriptsNotSupportedInEra
                    $ getIsCardanoEraConstraint era (AnyCardanoEra era)
    Just _ -> do
      case scriptLanguageSupportedInEra era anyScriptLanguage of
        Just sLangInEra ->
          case languageOfScriptLanguageInEra sLangInEra of
            SimpleScriptLanguage ->
              return . SimpleScriptWitness sLangInEra
                     $ SReferenceScript refTxIn (unPolicyId <$> mPid)
            PlutusScriptLanguage{} ->
              error "readScriptWitness: Should not be possible to specify a plutus script"
        Nothing ->
          left $ ScriptWitnessErrorScriptLanguageNotSupportedInEra anyScrLang (anyCardanoEra era)

validateScriptSupportedInEra :: CardanoEra era
                             -> ScriptInAnyLang
                             -> ExceptT ScriptWitnessError IO (ScriptInEra era)
validateScriptSupportedInEra era script@(ScriptInAnyLang lang _) =
    case toScriptInEra era script of
      Nothing -> left $ ScriptWitnessErrorScriptLanguageNotSupportedInEra
                          (AnyScriptLanguage lang) (anyCardanoEra era)
      Just script' -> pure script'

data ScriptDataError =
    ScriptDataErrorFile (FileError ())
  | ScriptDataErrorJsonParse !FilePath !String
  | ScriptDataErrorConversion !FilePath !ScriptDataJsonError
  | ScriptDataErrorValidation !FilePath !ScriptDataRangeError
  | ScriptDataErrorMetadataDecode !FilePath !CBOR.DecoderError
  | ScriptDataErrorJsonBytes !ScriptDataJsonBytesError

renderScriptDataError :: ScriptDataError -> Text
renderScriptDataError (ScriptDataErrorFile err) =
  Text.pack $ displayError err
renderScriptDataError (ScriptDataErrorJsonParse fp jsonErr) =
  Text.pack $ "Invalid JSON format in file: " <> show fp <>
              "\nJSON parse error: " <> jsonErr
renderScriptDataError (ScriptDataErrorConversion fp sDataJsonErr) =
  Text.pack $ "Error reading metadata at: " <> show fp <>
              "\n" <> displayError sDataJsonErr
renderScriptDataError (ScriptDataErrorValidation fp sDataRangeErr) =
  Text.pack $ "Error validating script data at: " <> show fp <> ":\n" <>
              displayError sDataRangeErr
renderScriptDataError (ScriptDataErrorMetadataDecode fp decoderErr) =
  Text.pack $ "Error decoding CBOR metadata at: " <> show fp <>
              " Error: " <> show decoderErr
renderScriptDataError (ScriptDataErrorJsonBytes e) =
  Text.pack $ displayError e


readScriptDatumOrFile :: ScriptDatumOrFile witctx
                      -> ExceptT ScriptDataError IO (ScriptDatum witctx)
readScriptDatumOrFile (ScriptDatumOrFileForTxIn df) = ScriptDatumForTxIn <$>
                                                        readScriptDataOrFile df
readScriptDatumOrFile InlineDatumPresentAtTxIn      = pure InlineScriptDatum
readScriptDatumOrFile NoScriptDatumOrFileForMint    = pure NoScriptDatumForMint
readScriptDatumOrFile NoScriptDatumOrFileForStake   = pure NoScriptDatumForStake

readScriptRedeemerOrFile :: ScriptRedeemerOrFile
                         -> ExceptT ScriptDataError IO ScriptRedeemer
readScriptRedeemerOrFile = readScriptDataOrFile

readScriptDataOrFile :: ScriptDataOrFile
                     -> ExceptT ScriptDataError IO 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


--
-- Handling decoding the variety of script languages and formats
--

data ScriptDecodeError =
       ScriptDecodeTextEnvelopeError TextEnvelopeError
     | ScriptDecodeSimpleScriptError JsonDecodeError
  deriving Show

instance Error ScriptDecodeError where
  displayError (ScriptDecodeTextEnvelopeError err) =
    "Error decoding script: " ++ displayError err
  displayError (ScriptDecodeSimpleScriptError err) =
    "Syntax error in script: " ++ displayError err


-- | Read a script file. The file can either be in the text envelope format
-- wrapping the binary representation of any of the supported script languages,
-- or alternatively it can be a JSON format file for one of the simple script
-- language versions.
--
readFileScriptInAnyLang :: FilePath
                        -> ExceptT (FileError ScriptDecodeError) IO
                                   ScriptInAnyLang
readFileScriptInAnyLang file = do
  scriptBytes <- handleIOExceptT (FileIOError file) $ BS.readFile file
  firstExceptT (FileError file) $ hoistEither $
    deserialiseScriptInAnyLang scriptBytes


deserialiseScriptInAnyLang :: BS.ByteString
                           -> Either ScriptDecodeError ScriptInAnyLang
deserialiseScriptInAnyLang bs =
    -- Accept either the text envelope format wrapping the binary serialisation,
    -- or accept the simple script language in its JSON format.
    --
    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 $ ScriptInAnyLang SimpleScriptLanguage $ SimpleScript script

      Right te ->
        case deserialiseFromTextEnvelopeAnyOf textEnvTypes te of
          Left  err    -> Left (ScriptDecodeTextEnvelopeError err)
          Right script -> Right script

  where
    -- TODO: Think of a way to get type checker to warn when there is a missing
    -- script version.
    textEnvTypes :: [FromSomeType HasTextEnvelope ScriptInAnyLang]
    textEnvTypes =
      [ FromSomeType (AsScript AsSimpleScript)
                     (ScriptInAnyLang SimpleScriptLanguage)

      , FromSomeType (AsScript AsPlutusScriptV1)
                     (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV1))

      , FromSomeType (AsScript AsPlutusScriptV2)
                     (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV2))
      ]

-- Tx & TxBody

newtype CddlTx = CddlTx {unCddlTx :: InAnyCardanoEra Tx} deriving (Show, Eq)

readFileTx :: FileOrPipe -> IO (Either CddlError (InAnyCardanoEra Tx))
readFileTx file = do
  eAnyTx <- readFileInAnyCardanoEra AsTx file
  case eAnyTx of
    Left e -> fmap unCddlTx <$> acceptTxCDDLSerialisation file e
    Right tx -> return $ Right tx

-- IncompleteCddlFormattedTx is an CDDL formatted tx or partial tx
-- (respectively needs additional witnesses or totally unwitnessed)
-- while UnwitnessedCliFormattedTxBody is CLI formatted TxBody and
-- needs to be key witnessed.

data IncompleteTx
  = UnwitnessedCliFormattedTxBody (InAnyCardanoEra TxBody)
  | IncompleteCddlFormattedTx (InAnyCardanoEra Tx)

readFileTxBody :: FileOrPipe -> IO (Either CddlError IncompleteTx)
readFileTxBody file = do
  eTxBody <- readFileInAnyCardanoEra AsTxBody file
  case eTxBody of
    Left e -> fmap (IncompleteCddlFormattedTx . unCddlTx) <$> acceptTxCDDLSerialisation file e
    Right txBody -> return $ Right $ UnwitnessedCliFormattedTxBody txBody

data CddlError = CddlErrorTextEnv
                   !(FileError TextEnvelopeError)
                   !(FileError TextEnvelopeCddlError)
               | CddlIOError (FileError TextEnvelopeError)
               deriving Show

instance Error CddlError where
  displayError (CddlErrorTextEnv textEnvErr cddlErr) =
    "Failed to decode neither the cli's serialisation format nor the ledger's \
    \CDDL serialisation format. TextEnvelope error: " <> displayError textEnvErr <> "\n" <>
    "TextEnvelopeCddl error: " <> displayError cddlErr
  displayError (CddlIOError e) = displayError e

acceptTxCDDLSerialisation
  :: FileOrPipe
  -> FileError TextEnvelopeError
  -> IO (Either CddlError CddlTx)
acceptTxCDDLSerialisation file err =
  case err of
   e@(FileError _ (TextEnvelopeDecodeError _)) ->
      first (CddlErrorTextEnv e) <$> readCddlTx file
   e@(FileError _ (TextEnvelopeAesonDecodeError _)) ->
      first (CddlErrorTextEnv e) <$> readCddlTx file
   e@(FileError _ (TextEnvelopeTypeError _ _)) ->
      first (CddlErrorTextEnv e) <$> readCddlTx file
   e@FileErrorTempFile{} -> return . Left $ CddlIOError e
   e@FileDoesNotExistError{} -> return . Left $ CddlIOError e
   e@FileIOError{} -> return . Left $ CddlIOError e

readCddlTx :: FileOrPipe -> IO (Either (FileError TextEnvelopeCddlError) CddlTx)
readCddlTx = readFileOrPipeTextEnvelopeCddlAnyOf teTypes
 where
    teTypes = [ FromCDDLTx "Witnessed Tx ByronEra" CddlTx
              , FromCDDLTx "Witnessed Tx ShelleyEra" CddlTx
              , FromCDDLTx "Witnessed Tx AllegraEra" CddlTx
              , FromCDDLTx "Witnessed Tx MaryEra" CddlTx
              , FromCDDLTx "Witnessed Tx AlonzoEra" CddlTx
              , FromCDDLTx "Witnessed Tx BabbageEra" CddlTx
              , FromCDDLTx "Witnessed Tx ConwayEra" CddlTx
              , FromCDDLTx "Unwitnessed Tx ByronEra" CddlTx
              , FromCDDLTx "Unwitnessed Tx ShelleyEra" CddlTx
              , FromCDDLTx "Unwitnessed Tx AllegraEra" CddlTx
              , FromCDDLTx "Unwitnessed Tx MaryEra" CddlTx
              , FromCDDLTx "Unwitnessed Tx AlonzoEra" CddlTx
              , FromCDDLTx "Unwitnessed Tx BabbageEra" CddlTx
              , FromCDDLTx "Unwitnessed Tx ConwayEra" CddlTx
              ]

-- Tx witnesses

newtype CddlWitness = CddlWitness { unCddlWitness :: InAnyCardanoEra KeyWitness}

readFileTxKeyWitness :: FilePath
                -> IO (Either CddlWitnessError (InAnyCardanoEra KeyWitness))
readFileTxKeyWitness fp = do
  file <- fileOrPipe fp
  eWitness <- readFileInAnyCardanoEra AsKeyWitness file
  case eWitness of
    Left e -> fmap unCddlWitness <$> acceptKeyWitnessCDDLSerialisation e
    Right keyWit -> return $ Right keyWit

data CddlWitnessError
  = CddlWitnessErrorTextEnv
      (FileError TextEnvelopeError)
      (FileError TextEnvelopeCddlError)
  | CddlWitnessIOError (FileError TextEnvelopeError)
  deriving Show

instance Error CddlWitnessError where
  displayError (CddlWitnessErrorTextEnv teErr cddlErr) =
    "Failed to decode neither the cli's serialisation format nor the ledger's \
    \CDDL serialisation format. TextEnvelope error: " <> displayError teErr <> "\n" <>
    "TextEnvelopeCddl error: " <> displayError cddlErr
  displayError (CddlWitnessIOError fileE) = displayError fileE


-- TODO: This is a stop gap to avoid modifying the TextEnvelope
-- related functions. We intend to remove this after fully deprecating
-- the cli's serialisation format
acceptKeyWitnessCDDLSerialisation
  :: FileError TextEnvelopeError
  -> IO (Either CddlWitnessError CddlWitness)
acceptKeyWitnessCDDLSerialisation err =
  case err of
    e@(FileError fp (TextEnvelopeDecodeError _)) ->
      first (CddlWitnessErrorTextEnv e) <$> readCddlWitness fp
    e@(FileError fp (TextEnvelopeAesonDecodeError _)) ->
      first (CddlWitnessErrorTextEnv e) <$> readCddlWitness fp
    e@(FileError fp (TextEnvelopeTypeError _ _)) ->
      first (CddlWitnessErrorTextEnv e) <$> readCddlWitness fp
    e@FileErrorTempFile{} -> return . Left $ CddlWitnessIOError e
    e@FileDoesNotExistError{} -> return . Left $ CddlWitnessIOError e
    e@FileIOError{} -> return . Left $ CddlWitnessIOError e

readCddlWitness
  :: FilePath
  -> IO (Either (FileError TextEnvelopeCddlError) CddlWitness)
readCddlWitness fp = do
  readFileTextEnvelopeCddlAnyOf teTypes fp
 where
  teTypes = [ FromCDDLWitness "TxWitness ShelleyEra" CddlWitness
            , FromCDDLWitness "TxWitness AllegraEra" CddlWitness
            , FromCDDLWitness "TxWitness MaryEra" CddlWitness
            , FromCDDLWitness "TxWitness AlonzoEra" CddlWitness
            , FromCDDLWitness "TxWitness BabbageEra" CddlWitness
            ]

-- Witness handling

data SomeWitness
  = AByronSigningKey           (SigningKey ByronKey) (Maybe (Address ByronAddr))
  | APaymentSigningKey         (SigningKey PaymentKey)
  | APaymentExtendedSigningKey (SigningKey PaymentExtendedKey)
  | AStakeSigningKey           (SigningKey StakeKey)
  | AStakeExtendedSigningKey   (SigningKey StakeExtendedKey)
  | AStakePoolSigningKey       (SigningKey StakePoolKey)
  | AGenesisSigningKey         (SigningKey GenesisKey)
  | AGenesisExtendedSigningKey (SigningKey GenesisExtendedKey)
  | AGenesisDelegateSigningKey (SigningKey GenesisDelegateKey)
  | AGenesisDelegateExtendedSigningKey
                               (SigningKey GenesisDelegateExtendedKey)
  | AGenesisUTxOSigningKey     (SigningKey GenesisUTxOKey)


-- | Data required for constructing a Shelley bootstrap witness.
data ShelleyBootstrapWitnessSigningKeyData
  = ShelleyBootstrapWitnessSigningKeyData
      !(SigningKey ByronKey)
      -- ^ Byron signing key.
      !(Maybe (Address ByronAddr))
      -- ^ An optionally specified Byron address.
      --
      -- If specified, both the network ID and derivation path are extracted
      -- from the address and used in the construction of the Byron witness.

-- | Some kind of Byron or Shelley witness.
data ByronOrShelleyWitness
  = AByronWitness !ShelleyBootstrapWitnessSigningKeyData
  | AShelleyKeyWitness !ShelleyWitnessSigningKey

categoriseSomeWitness :: SomeWitness -> ByronOrShelleyWitness
categoriseSomeWitness swsk =
  case swsk of
    AByronSigningKey           sk addr -> AByronWitness (ShelleyBootstrapWitnessSigningKeyData sk addr)
    APaymentSigningKey         sk      -> AShelleyKeyWitness (WitnessPaymentKey         sk)
    APaymentExtendedSigningKey sk      -> AShelleyKeyWitness (WitnessPaymentExtendedKey sk)
    AStakeSigningKey           sk      -> AShelleyKeyWitness (WitnessStakeKey           sk)
    AStakeExtendedSigningKey   sk      -> AShelleyKeyWitness (WitnessStakeExtendedKey   sk)
    AStakePoolSigningKey       sk      -> AShelleyKeyWitness (WitnessStakePoolKey       sk)
    AGenesisSigningKey         sk      -> AShelleyKeyWitness (WitnessGenesisKey sk)
    AGenesisExtendedSigningKey sk      -> AShelleyKeyWitness (WitnessGenesisExtendedKey sk)
    AGenesisDelegateSigningKey sk      -> AShelleyKeyWitness (WitnessGenesisDelegateKey sk)
    AGenesisDelegateExtendedSigningKey sk
                                       -> AShelleyKeyWitness (WitnessGenesisDelegateExtendedKey sk)
    AGenesisUTxOSigningKey     sk      -> AShelleyKeyWitness (WitnessGenesisUTxOKey     sk)

data ReadWitnessSigningDataError
  = ReadWitnessSigningDataSigningKeyDecodeError !(FileError InputDecodeError)
  | ReadWitnessSigningDataScriptError !(FileError JsonDecodeError)
  | ReadWitnessSigningDataSigningKeyAndAddressMismatch
  -- ^ A Byron address was specified alongside a non-Byron signing key.
  deriving Show

-- | Render an error message for a 'ReadWitnessSigningDataError'.
renderReadWitnessSigningDataError :: ReadWitnessSigningDataError -> Text
renderReadWitnessSigningDataError err =
  case err of
    ReadWitnessSigningDataSigningKeyDecodeError fileErr ->
      "Error reading signing key: " <> Text.pack (displayError fileErr)
    ReadWitnessSigningDataScriptError fileErr ->
      "Error reading script: " <> Text.pack (displayError fileErr)
    ReadWitnessSigningDataSigningKeyAndAddressMismatch ->
      "Only a Byron signing key may be accompanied by a Byron address."

readWitnessSigningData
  :: WitnessSigningData
  -> IO (Either ReadWitnessSigningDataError SomeWitness)
readWitnessSigningData (KeyWitnessSigningData skFile mbByronAddr) = do
    eRes <- first ReadWitnessSigningDataSigningKeyDecodeError
             <$> readKeyFileAnyOf bech32FileTypes textEnvFileTypes skFile
    return $ do
      res <- eRes
      case (res, mbByronAddr) of
        (AByronSigningKey _ _, Just _) -> pure res
        (AByronSigningKey _ _, Nothing) -> pure res
        (_, Nothing) -> pure res
        (_, Just _) ->
          -- A Byron address should only be specified along with a Byron signing key.
          Left ReadWitnessSigningDataSigningKeyAndAddressMismatch
  where
    textEnvFileTypes =
      [ FromSomeType (AsSigningKey AsByronKey)
                          (`AByronSigningKey` mbByronAddr)
      , FromSomeType (AsSigningKey AsPaymentKey)
                          APaymentSigningKey
      , FromSomeType (AsSigningKey AsPaymentExtendedKey)
                          APaymentExtendedSigningKey
      , FromSomeType (AsSigningKey AsStakeKey)
                          AStakeSigningKey
      , FromSomeType (AsSigningKey AsStakeExtendedKey)
                          AStakeExtendedSigningKey
      , FromSomeType (AsSigningKey AsStakePoolKey)
                          AStakePoolSigningKey
      , FromSomeType (AsSigningKey AsGenesisKey)
                          AGenesisSigningKey
      , FromSomeType (AsSigningKey AsGenesisExtendedKey)
                          AGenesisExtendedSigningKey
      , FromSomeType (AsSigningKey AsGenesisDelegateKey)
                          AGenesisDelegateSigningKey
      , FromSomeType (AsSigningKey AsGenesisDelegateExtendedKey)
                          AGenesisDelegateExtendedSigningKey
      , FromSomeType (AsSigningKey AsGenesisUTxOKey)
                          AGenesisUTxOSigningKey
      ]

    bech32FileTypes =
      [ FromSomeType (AsSigningKey AsPaymentKey)
                          APaymentSigningKey
      , FromSomeType (AsSigningKey AsPaymentExtendedKey)
                          APaymentExtendedSigningKey
      , FromSomeType (AsSigningKey AsStakeKey)
                          AStakeSigningKey
      , FromSomeType (AsSigningKey AsStakeExtendedKey)
                          AStakeExtendedSigningKey
      , FromSomeType (AsSigningKey AsStakePoolKey)
                          AStakePoolSigningKey
      ]

-- Required signers

data RequiredSignerError
  = RequiredSignerErrorFile (FileError InputDecodeError)
  | RequiredSignerErrorByronKey (SigningKeyFile In)
  deriving Show

instance Error RequiredSignerError where
  displayError (RequiredSignerErrorFile e) = displayError e
  displayError (RequiredSignerErrorByronKey (File byronSkeyfile)) =
    "Byron witnesses cannot be used for required signers: " <> byronSkeyfile

readRequiredSigner :: RequiredSigner -> IO (Either RequiredSignerError (Hash PaymentKey))
readRequiredSigner (RequiredSignerHash h) = return $ Right h
readRequiredSigner (RequiredSignerSkeyFile skFile) = do
  eKeyWit <- first RequiredSignerErrorFile <$> readKeyFileAnyOf bech32FileTypes textEnvFileTypes skFile
  return $ do
    keyWit <- eKeyWit
    case categoriseSomeWitness keyWit of
      AByronWitness _ ->
        Left $ RequiredSignerErrorByronKey skFile
      AShelleyKeyWitness skey ->
        return . getHash $ toShelleySigningKey skey
 where
   textEnvFileTypes =
     [ FromSomeType (AsSigningKey AsPaymentKey) APaymentSigningKey
     , FromSomeType (AsSigningKey AsPaymentExtendedKey) APaymentExtendedSigningKey
     , FromSomeType (AsSigningKey AsStakePoolKey) AStakePoolSigningKey
     , FromSomeType (AsSigningKey AsGenesisDelegateKey) AGenesisDelegateSigningKey
     ]
   bech32FileTypes = []

   getHash :: ShelleySigningKey -> Hash PaymentKey
   getHash (ShelleyExtendedSigningKey sk) =
     let extSKey = PaymentExtendedSigningKey sk
         payVKey = castVerificationKey $ getVerificationKey extSKey
     in verificationKeyHash payVKey
   getHash (ShelleyNormalSigningKey sk) =
     verificationKeyHash . getVerificationKey $ PaymentSigningKey sk

data VoteError
  = VoteErrorFile (FileError TextEnvelopeError)
  | VotesNotSupportedInEra AnyCardanoEra
  deriving Show

readTxVotes :: ()
  => ConwayEraOnwards era
  -> [VoteFile In]
  -> IO (Either VoteError (TxVotes era))
readTxVotes _ [] = return $ Right TxVotesNone
readTxVotes w files = runExceptT $ do
  TxVotes w <$> forM files (ExceptT . readVoteFile w)

readVoteFile
  :: ConwayEraOnwards era
  -> VoteFile In
  -> IO (Either VoteError (VotingProcedure era))
readVoteFile w fp =
  first VoteErrorFile <$> conwayEraOnwardsConstraints w (readFileTextEnvelope AsVote fp)

data ConstitutionError
  = ConstitutionErrorFile (FileError TextEnvelopeError)
  | ConstitutionsNotSupportedInEra AnyCardanoEra
  deriving Show

readTxNewConstitutionActions
  :: CardanoEra era
  -> [NewConstitutionFile In]
  -> IO (Either ConstitutionError (TxGovernanceActions era))
readTxNewConstitutionActions _ [] = return $ Right TxGovernanceActionsNone
readTxNewConstitutionActions era files =
  runExceptT $
    featureInEra
      (left $ ConstitutionsNotSupportedInEra $ cardanoEraConstraints era $ AnyCardanoEra era)
      (\w -> do
        constitutions <- newExceptT $ sequence <$> mapM (readConstitution w) files
        pure $ TxGovernanceActions w constitutions
      )
      era

readConstitution
  :: ConwayEraOnwards era
  -> NewConstitutionFile In
  -> IO (Either ConstitutionError (Proposal era))
readConstitution w fp =
  first ConstitutionErrorFile
    <$> conwayEraOnwardsConstraints w (readFileTextEnvelope AsProposal fp)

-- Misc

readFileInAnyCardanoEra
  :: ( HasTextEnvelope (thing ByronEra)
     , HasTextEnvelope (thing ShelleyEra)
     , HasTextEnvelope (thing AllegraEra)
     , HasTextEnvelope (thing MaryEra)
     , HasTextEnvelope (thing AlonzoEra)
     , HasTextEnvelope (thing BabbageEra)
     )
  => (forall era. AsType era -> AsType (thing era))
  -> FileOrPipe
  -> IO (Either (FileError TextEnvelopeError) (InAnyCardanoEra thing))
readFileInAnyCardanoEra asThing =
 readFileOrPipeTextEnvelopeAnyOf
   [ FromSomeType (asThing AsByronEra)   (InAnyCardanoEra ByronEra)
   , FromSomeType (asThing AsShelleyEra) (InAnyCardanoEra ShelleyEra)
   , FromSomeType (asThing AsAllegraEra) (InAnyCardanoEra AllegraEra)
   , FromSomeType (asThing AsMaryEra)    (InAnyCardanoEra MaryEra)
   , FromSomeType (asThing AsAlonzoEra)  (InAnyCardanoEra AlonzoEra)
   , FromSomeType (asThing AsBabbageEra) (InAnyCardanoEra BabbageEra)
   ]

-- | We need a type for handling files that may be actually be things like
-- pipes. Currently the CLI makes no guarantee that a "file" will only
-- be read once. This is a problem for a user who who expects to be able to pass
-- a pipe. To handle this, we have a type for representing either files or pipes
-- where the contents will be saved in memory if what we're reading is a pipe (so
-- it can be re-read later). Unfortunately this means we can't easily stream data
-- from pipes, but at present that's not an issue.
data FileOrPipe = FileOrPipe FilePath (IORef (Maybe LBS.ByteString))


instance Show FileOrPipe where
    show (FileOrPipe fp _) = show fp

fileOrPipe :: FilePath -> IO FileOrPipe
fileOrPipe fp = FileOrPipe fp <$> newIORef Nothing

-- | Get the path backing a FileOrPipe. This should primarily be used when
-- generating error messages for a user. A user should not call directly
-- call a function like readFile on the result of this function
fileOrPipePath :: FileOrPipe -> FilePath
fileOrPipePath (FileOrPipe fp _) = fp

fileOrPipeCache :: FileOrPipe -> IO (Maybe LBS.ByteString)
fileOrPipeCache (FileOrPipe _ c) = readIORef c

-- | Get the contents of a file or pipe. This function reads the entire
-- contents of the file or pipe, and is blocking.
readFileOrPipe :: FileOrPipe -> IO LBS.ByteString
readFileOrPipe (FileOrPipe fp cacheRef) = do
    cached <- readIORef cacheRef
    case cached of
      Just dat -> pure dat
      Nothing -> bracket
        (openFileBlocking fp ReadMode)
        hClose
        (\handle -> do
          -- An arbitrary block size.
          let blockSize = 4096
          let go acc = do
                next <- BS.hGet handle blockSize
                if BS.null next
                then pure acc
                else go (acc <> Builder.byteString next)
          contents <- go mempty
          let dat = Builder.toLazyByteString contents
          -- If our file is not seekable, it's likely a pipe, so we need to
          -- save the result for subsequent calls
          seekable <- hIsSeekable handle
          unless seekable (writeIORef cacheRef (Just dat))
          pure dat)

readFileOrPipeTextEnvelopeAnyOf
  :: [FromSomeType HasTextEnvelope b]
  -> FileOrPipe
  -> IO (Either (FileError TextEnvelopeError) b)
readFileOrPipeTextEnvelopeAnyOf types file = do
    let path = fileOrPipePath file
    runExceptT $ do
      content <- handleIOExceptT (FileIOError path) $ readFileOrPipe file
      firstExceptT (FileError path) $ hoistEither $ do
        te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecode' content
        deserialiseFromTextEnvelopeAnyOf types te

readFileOrPipeTextEnvelopeCddlAnyOf
  :: [FromSomeTypeCDDL TextEnvelopeCddl b]
  -> FileOrPipe
  -> IO (Either (FileError TextEnvelopeCddlError) b)
readFileOrPipeTextEnvelopeCddlAnyOf types file = do
  let path = fileOrPipePath file
  runExceptT $ do
    te <- newExceptT $ readTextEnvelopeCddlFromFileOrPipe file
    firstExceptT (FileError path) $ hoistEither $ do
      deserialiseFromTextEnvelopeCddlAnyOf types te

readTextEnvelopeCddlFromFileOrPipe
  :: FileOrPipe
  -> IO (Either (FileError TextEnvelopeCddlError) TextEnvelopeCddl)
readTextEnvelopeCddlFromFileOrPipe file = do
  let path = fileOrPipePath file
  runExceptT $ do
    bs <- handleIOExceptT (FileIOError path) $
            readFileOrPipe file
    firstExceptT (FileError path . TextEnvelopeCddlAesonDecodeError path)
      . hoistEither $ Aeson.eitherDecode' bs