{-# LANGUAGE GADTs #-}

module Cardano.CLI.Byron.UpdateProposal
  ( ByronUpdateProposalError(..)
  , runProposalCreation
  , readByronUpdateProposal
  , renderByronUpdateProposalError
  , submitByronUpdateProposal
  ) where

import           Cardano.Prelude

import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither)
import           Control.Tracer (stdoutTracer, traceWith)
import qualified Data.ByteString as BS

import           Cardano.Chain.Update (InstallerHash (..), ProtocolVersion (..),
                     SoftwareVersion (..), SystemTag (..))

import           Ouroboros.Consensus.Ledger.SupportsMempool (txId)
import           Ouroboros.Consensus.Util.Condense (condense)

import           Cardano.Api (NetworkId, SerialiseAsRawBytes (..))
import           Cardano.Api.Byron (AsType (AsByronUpdateProposal), ByronProtocolParametersUpdate,
                     ByronUpdateProposal, makeByronUpdateProposal, toByronLedgerUpdateProposal)

import           Cardano.CLI.Byron.Genesis (ByronGenesisError)
import           Cardano.CLI.Byron.Key (ByronKeyFailure, readByronSigningKey)
import           Cardano.CLI.Byron.Tx (ByronTxError, nodeSubmitTx)
import           Cardano.CLI.Helpers (HelpersError, ensureNewFileLBS, renderHelpersError, textShow)
import           Cardano.CLI.Shelley.Commands (ByronKeyFormat (..))
import           Cardano.CLI.Types

data ByronUpdateProposalError
  = ByronReadUpdateProposalFileFailure !FilePath !Text
  | ByronUpdateProposalWriteError !HelpersError
  | ByronUpdateProposalGenesisReadError !FilePath !ByronGenesisError
  | ByronUpdateProposalTxError !ByronTxError
  | ReadSigningKeyFailure !FilePath !ByronKeyFailure
  | UpdateProposalDecodingError !FilePath
  deriving Int -> ByronUpdateProposalError -> ShowS
[ByronUpdateProposalError] -> ShowS
ByronUpdateProposalError -> String
(Int -> ByronUpdateProposalError -> ShowS)
-> (ByronUpdateProposalError -> String)
-> ([ByronUpdateProposalError] -> ShowS)
-> Show ByronUpdateProposalError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ByronUpdateProposalError] -> ShowS
$cshowList :: [ByronUpdateProposalError] -> ShowS
show :: ByronUpdateProposalError -> String
$cshow :: ByronUpdateProposalError -> String
showsPrec :: Int -> ByronUpdateProposalError -> ShowS
$cshowsPrec :: Int -> ByronUpdateProposalError -> ShowS
Show

renderByronUpdateProposalError :: ByronUpdateProposalError -> Text
renderByronUpdateProposalError :: ByronUpdateProposalError -> Text
renderByronUpdateProposalError ByronUpdateProposalError
err =
  case ByronUpdateProposalError
err of
    ByronReadUpdateProposalFileFailure String
fp Text
rErr ->
      Text
"Error reading update proposal at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
textShow String
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
textShow Text
rErr
    ByronUpdateProposalWriteError HelpersError
hErr ->
      Text
"Error writing update proposal: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HelpersError -> Text
renderHelpersError HelpersError
hErr
    ByronUpdateProposalGenesisReadError String
fp ByronGenesisError
rErr ->
      Text
"Error reading update proposal at: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
textShow String
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByronGenesisError -> Text
forall a. Show a => a -> Text
textShow ByronGenesisError
rErr
    ByronUpdateProposalTxError ByronTxError
txErr ->
      Text
"Error submitting update proposal: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByronTxError -> Text
forall a. Show a => a -> Text
textShow ByronTxError
txErr
    ReadSigningKeyFailure String
fp ByronKeyFailure
rErr ->
      Text
"Error reading signing key at: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
textShow String
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByronKeyFailure -> Text
forall a. Show a => a -> Text
textShow ByronKeyFailure
rErr
    UpdateProposalDecodingError String
fp ->
      Text
"Error decoding update proposal at: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
textShow String
fp

runProposalCreation
  :: NetworkId
  -> SigningKeyFile
  -> ProtocolVersion
  -> SoftwareVersion
  -> SystemTag
  -> InstallerHash
  -> FilePath
  -> ByronProtocolParametersUpdate
  -> ExceptT ByronUpdateProposalError IO ()
runProposalCreation :: NetworkId
-> SigningKeyFile
-> ProtocolVersion
-> SoftwareVersion
-> SystemTag
-> InstallerHash
-> String
-> ByronProtocolParametersUpdate
-> ExceptT ByronUpdateProposalError IO ()
runProposalCreation NetworkId
nw sKey :: SigningKeyFile
sKey@(SigningKeyFile String
sKeyfp) ProtocolVersion
pVer SoftwareVersion
sVer
                    SystemTag
sysTag InstallerHash
insHash String
outputFp ByronProtocolParametersUpdate
params = do
  SomeByronSigningKey
sK <- (ByronKeyFailure -> ByronUpdateProposalError)
-> ExceptT ByronKeyFailure IO SomeByronSigningKey
-> ExceptT ByronUpdateProposalError IO SomeByronSigningKey
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (String -> ByronKeyFailure -> ByronUpdateProposalError
ReadSigningKeyFailure String
sKeyfp) (ExceptT ByronKeyFailure IO SomeByronSigningKey
 -> ExceptT ByronUpdateProposalError IO SomeByronSigningKey)
-> ExceptT ByronKeyFailure IO SomeByronSigningKey
-> ExceptT ByronUpdateProposalError IO SomeByronSigningKey
forall a b. (a -> b) -> a -> b
$ ByronKeyFormat
-> SigningKeyFile -> ExceptT ByronKeyFailure IO SomeByronSigningKey
readByronSigningKey ByronKeyFormat
NonLegacyByronKeyFormat SigningKeyFile
sKey
  let proposal :: ByronUpdateProposal
proposal = NetworkId
-> ProtocolVersion
-> SoftwareVersion
-> SystemTag
-> InstallerHash
-> SomeByronSigningKey
-> ByronProtocolParametersUpdate
-> ByronUpdateProposal
makeByronUpdateProposal NetworkId
nw ProtocolVersion
pVer SoftwareVersion
sVer SystemTag
sysTag InstallerHash
insHash SomeByronSigningKey
sK ByronProtocolParametersUpdate
params
  (HelpersError -> ByronUpdateProposalError)
-> ExceptT HelpersError IO ()
-> ExceptT ByronUpdateProposalError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT HelpersError -> ByronUpdateProposalError
ByronUpdateProposalWriteError (ExceptT HelpersError IO ()
 -> ExceptT ByronUpdateProposalError IO ())
-> ExceptT HelpersError IO ()
-> ExceptT ByronUpdateProposalError IO ()
forall a b. (a -> b) -> a -> b
$
    String -> ByteString -> ExceptT HelpersError IO ()
ensureNewFileLBS String
outputFp (ByteString -> ExceptT HelpersError IO ())
-> ByteString -> ExceptT HelpersError IO ()
forall a b. (a -> b) -> a -> b
$ ByronUpdateProposal -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes ByronUpdateProposal
proposal

readByronUpdateProposal :: FilePath -> ExceptT ByronUpdateProposalError IO ByronUpdateProposal
readByronUpdateProposal :: String -> ExceptT ByronUpdateProposalError IO ByronUpdateProposal
readByronUpdateProposal String
fp = do
  ByteString
proposalBs <- (IOException -> ByronUpdateProposalError)
-> IO ByteString -> ExceptT ByronUpdateProposalError IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (String -> Text -> ByronUpdateProposalError
ByronReadUpdateProposalFileFailure String
fp (Text -> ByronUpdateProposalError)
-> (IOException -> Text) -> IOException -> ByronUpdateProposalError
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Text) -> (IOException -> String) -> IOException -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IOException -> String
forall e. Exception e => e -> String
displayException)
                  (IO ByteString -> ExceptT ByronUpdateProposalError IO ByteString)
-> IO ByteString -> ExceptT ByronUpdateProposalError IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
fp
  let mProposal :: Maybe ByronUpdateProposal
mProposal = AsType ByronUpdateProposal
-> ByteString -> Maybe ByronUpdateProposal
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
deserialiseFromRawBytes AsType ByronUpdateProposal
AsByronUpdateProposal ByteString
proposalBs
  Either ByronUpdateProposalError ByronUpdateProposal
-> ExceptT ByronUpdateProposalError IO ByronUpdateProposal
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either ByronUpdateProposalError ByronUpdateProposal
 -> ExceptT ByronUpdateProposalError IO ByronUpdateProposal)
-> Either ByronUpdateProposalError ByronUpdateProposal
-> ExceptT ByronUpdateProposalError IO ByronUpdateProposal
forall a b. (a -> b) -> a -> b
$ Either ByronUpdateProposalError ByronUpdateProposal
-> (ByronUpdateProposal
    -> Either ByronUpdateProposalError ByronUpdateProposal)
-> Maybe ByronUpdateProposal
-> Either ByronUpdateProposalError ByronUpdateProposal
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByronUpdateProposalError
-> Either ByronUpdateProposalError ByronUpdateProposal
forall a b. a -> Either a b
Left (ByronUpdateProposalError
 -> Either ByronUpdateProposalError ByronUpdateProposal)
-> ByronUpdateProposalError
-> Either ByronUpdateProposalError ByronUpdateProposal
forall a b. (a -> b) -> a -> b
$ String -> ByronUpdateProposalError
UpdateProposalDecodingError String
fp) ByronUpdateProposal
-> Either ByronUpdateProposalError ByronUpdateProposal
forall a b. b -> Either a b
Right Maybe ByronUpdateProposal
mProposal

submitByronUpdateProposal
  :: NetworkId
  -> FilePath
  -> ExceptT ByronUpdateProposalError IO ()
submitByronUpdateProposal :: NetworkId -> String -> ExceptT ByronUpdateProposalError IO ()
submitByronUpdateProposal NetworkId
network String
proposalFp = do
    ByronUpdateProposal
proposal  <- String -> ExceptT ByronUpdateProposalError IO ByronUpdateProposal
readByronUpdateProposal String
proposalFp
    let genTx :: GenTx ByronBlock
genTx = ByronUpdateProposal -> GenTx ByronBlock
toByronLedgerUpdateProposal ByronUpdateProposal
proposal
    Tracer (ExceptT ByronUpdateProposalError IO) String
-> String -> ExceptT ByronUpdateProposalError IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer (ExceptT ByronUpdateProposalError IO) String
forall (m :: * -> *). MonadIO m => Tracer m String
stdoutTracer (String -> ExceptT ByronUpdateProposalError IO ())
-> String -> ExceptT ByronUpdateProposalError IO ()
forall a b. (a -> b) -> a -> b
$
      String
"Update proposal TxId: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TxId (GenTx ByronBlock) -> String
forall a. Condense a => a -> String
condense (GenTx ByronBlock -> TxId (GenTx ByronBlock)
forall tx. HasTxId tx => tx -> TxId tx
txId GenTx ByronBlock
genTx)
    (ByronTxError -> ByronUpdateProposalError)
-> ExceptT ByronTxError IO ()
-> ExceptT ByronUpdateProposalError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ByronTxError -> ByronUpdateProposalError
ByronUpdateProposalTxError (ExceptT ByronTxError IO ()
 -> ExceptT ByronUpdateProposalError IO ())
-> ExceptT ByronTxError IO ()
-> ExceptT ByronUpdateProposalError IO ()
forall a b. (a -> b) -> a -> b
$ NetworkId -> GenTx ByronBlock -> ExceptT ByronTxError IO ()
nodeSubmitTx NetworkId
network GenTx ByronBlock
genTx