{-# LANGUAGE GADTs #-}

module Cardano.CLI.Byron.Vote
  ( ByronVoteError(..)
  , readByronVote
  , renderByronVoteError
  , runVoteCreation
  , submitByronVote
  ) where

import           Cardano.Prelude

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


import qualified Cardano.Binary as Binary
import           Cardano.CLI.Byron.UpdateProposal (ByronUpdateProposalError,
                     readByronUpdateProposal)
import           Ouroboros.Consensus.Ledger.SupportsMempool (txId)
import           Ouroboros.Consensus.Util.Condense (condense)

import           Cardano.Api.Byron

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)
import           Cardano.CLI.Shelley.Commands (ByronKeyFormat (..))
import           Cardano.CLI.Types


data ByronVoteError
  = ByronVoteDecodingError !FilePath
  | ByronVoteGenesisReadError !ByronGenesisError
  | ByronVoteKeyReadFailure !ByronKeyFailure
  | ByronVoteReadFileFailure !FilePath !Text
  | ByronVoteTxSubmissionError !ByronTxError
  | ByronVoteUpdateProposalFailure !ByronUpdateProposalError
  | ByronVoteUpdateProposalDecodingError !Binary.DecoderError
  | ByronVoteUpdateHelperError !HelpersError
  deriving Int -> ByronVoteError -> ShowS
[ByronVoteError] -> ShowS
ByronVoteError -> String
(Int -> ByronVoteError -> ShowS)
-> (ByronVoteError -> String)
-> ([ByronVoteError] -> ShowS)
-> Show ByronVoteError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ByronVoteError] -> ShowS
$cshowList :: [ByronVoteError] -> ShowS
show :: ByronVoteError -> String
$cshow :: ByronVoteError -> String
showsPrec :: Int -> ByronVoteError -> ShowS
$cshowsPrec :: Int -> ByronVoteError -> ShowS
Show

renderByronVoteError :: ByronVoteError -> Text
renderByronVoteError :: ByronVoteError -> Text
renderByronVoteError ByronVoteError
bVerr =
  case ByronVoteError
bVerr of
    ByronVoteDecodingError String
fp -> Text
"Error decoding Byron vote at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  String -> Text
Text.pack String
fp
    ByronVoteGenesisReadError ByronGenesisError
genErr -> Text
"Error reading the genesis file:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (ByronGenesisError -> String
forall a b. (Show a, ConvertText String b) => a -> b
show ByronGenesisError
genErr)
    ByronVoteReadFileFailure String
fp Text
err -> Text
"Error reading Byron vote at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack 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
err
    ByronVoteTxSubmissionError ByronTxError
txErr -> Text
"Error submitting the transaction: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (ByronTxError -> String
forall a b. (Show a, ConvertText String b) => a -> b
show ByronTxError
txErr)
    ByronVoteUpdateProposalDecodingError DecoderError
err -> Text
"Error decoding Byron update proposal: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (DecoderError -> String
forall a b. (Show a, ConvertText String b) => a -> b
show DecoderError
err)
    ByronVoteUpdateProposalFailure ByronUpdateProposalError
err -> Text
"Error reading the update proposal: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (ByronUpdateProposalError -> String
forall a b. (Show a, ConvertText String b) => a -> b
show ByronUpdateProposalError
err)
    ByronVoteUpdateHelperError HelpersError
err ->Text
"Error creating the vote: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (HelpersError -> String
forall a b. (Show a, ConvertText String b) => a -> b
show HelpersError
err)
    ByronVoteKeyReadFailure ByronKeyFailure
err -> Text
"Error reading the signing key: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (ByronKeyFailure -> String
forall a b. (Show a, ConvertText String b) => a -> b
show ByronKeyFailure
err)


runVoteCreation
  :: NetworkId
  -> SigningKeyFile
  -> FilePath
  -> Bool
  -> FilePath
  -> ExceptT ByronVoteError IO ()
runVoteCreation :: NetworkId
-> SigningKeyFile
-> String
-> Bool
-> String
-> ExceptT ByronVoteError IO ()
runVoteCreation NetworkId
nw SigningKeyFile
sKey String
upPropFp Bool
voteBool String
outputFp = do
  SomeByronSigningKey
sK <- (ByronKeyFailure -> ByronVoteError)
-> ExceptT ByronKeyFailure IO SomeByronSigningKey
-> ExceptT ByronVoteError IO SomeByronSigningKey
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ByronKeyFailure -> ByronVoteError
ByronVoteKeyReadFailure (ExceptT ByronKeyFailure IO SomeByronSigningKey
 -> ExceptT ByronVoteError IO SomeByronSigningKey)
-> ExceptT ByronKeyFailure IO SomeByronSigningKey
-> ExceptT ByronVoteError IO SomeByronSigningKey
forall a b. (a -> b) -> a -> b
$ ByronKeyFormat
-> SigningKeyFile -> ExceptT ByronKeyFailure IO SomeByronSigningKey
readByronSigningKey ByronKeyFormat
NonLegacyByronKeyFormat SigningKeyFile
sKey
  ByronUpdateProposal
proposal <- (ByronUpdateProposalError -> ByronVoteError)
-> ExceptT ByronUpdateProposalError IO ByronUpdateProposal
-> ExceptT ByronVoteError IO ByronUpdateProposal
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ByronUpdateProposalError -> ByronVoteError
ByronVoteUpdateProposalFailure (ExceptT ByronUpdateProposalError IO ByronUpdateProposal
 -> ExceptT ByronVoteError IO ByronUpdateProposal)
-> ExceptT ByronUpdateProposalError IO ByronUpdateProposal
-> ExceptT ByronVoteError IO ByronUpdateProposal
forall a b. (a -> b) -> a -> b
$ String -> ExceptT ByronUpdateProposalError IO ByronUpdateProposal
readByronUpdateProposal String
upPropFp
  let vote :: ByronVote
vote = NetworkId
-> SomeByronSigningKey -> ByronUpdateProposal -> Bool -> ByronVote
makeByronVote NetworkId
nw SomeByronSigningKey
sK ByronUpdateProposal
proposal Bool
voteBool
  (HelpersError -> ByronVoteError)
-> ExceptT HelpersError IO () -> ExceptT ByronVoteError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT HelpersError -> ByronVoteError
ByronVoteUpdateHelperError (ExceptT HelpersError IO () -> ExceptT ByronVoteError IO ())
-> (ByteString -> ExceptT HelpersError IO ())
-> ByteString
-> ExceptT ByronVoteError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> ByteString -> ExceptT HelpersError IO ()
ensureNewFileLBS String
outputFp
    (ByteString -> ExceptT ByronVoteError IO ())
-> ByteString -> ExceptT ByronVoteError IO ()
forall a b. (a -> b) -> a -> b
$ ByronVote -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes ByronVote
vote

submitByronVote
  :: NetworkId
  -> FilePath
  -> ExceptT ByronVoteError IO ()
submitByronVote :: NetworkId -> String -> ExceptT ByronVoteError IO ()
submitByronVote NetworkId
network String
voteFp = do
    ByronVote
vote <- String -> ExceptT ByronVoteError IO ByronVote
readByronVote String
voteFp
    let genTx :: GenTx ByronBlock
genTx = ByronVote -> GenTx ByronBlock
toByronLedgertoByronVote ByronVote
vote
    Tracer (ExceptT ByronVoteError IO) String
-> String -> ExceptT ByronVoteError IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer (ExceptT ByronVoteError IO) String
forall (m :: * -> *). MonadIO m => Tracer m String
stdoutTracer (String
"Vote 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 -> ByronVoteError)
-> ExceptT ByronTxError IO () -> ExceptT ByronVoteError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ByronTxError -> ByronVoteError
ByronVoteTxSubmissionError (ExceptT ByronTxError IO () -> ExceptT ByronVoteError IO ())
-> ExceptT ByronTxError IO () -> ExceptT ByronVoteError IO ()
forall a b. (a -> b) -> a -> b
$ NetworkId -> GenTx ByronBlock -> ExceptT ByronTxError IO ()
nodeSubmitTx NetworkId
network GenTx ByronBlock
genTx

readByronVote :: FilePath -> ExceptT ByronVoteError IO ByronVote
readByronVote :: String -> ExceptT ByronVoteError IO ByronVote
readByronVote String
fp = do
  ByteString
voteBs <- IO ByteString -> ExceptT ByronVoteError IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT ByronVoteError IO ByteString)
-> IO ByteString -> ExceptT ByronVoteError IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
fp
  let mVote :: Maybe ByronVote
mVote = AsType ByronVote -> ByteString -> Maybe ByronVote
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
deserialiseFromRawBytes AsType ByronVote
AsByronVote ByteString
voteBs
  Either ByronVoteError ByronVote
-> ExceptT ByronVoteError IO ByronVote
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either ByronVoteError ByronVote
 -> ExceptT ByronVoteError IO ByronVote)
-> Either ByronVoteError ByronVote
-> ExceptT ByronVoteError IO ByronVote
forall a b. (a -> b) -> a -> b
$ Either ByronVoteError ByronVote
-> (ByronVote -> Either ByronVoteError ByronVote)
-> Maybe ByronVote
-> Either ByronVoteError ByronVote
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByronVoteError -> Either ByronVoteError ByronVote
forall a b. a -> Either a b
Left (ByronVoteError -> Either ByronVoteError ByronVote)
-> ByronVoteError -> Either ByronVoteError ByronVote
forall a b. (a -> b) -> a -> b
$ String -> ByronVoteError
ByronVoteDecodingError String
fp) ByronVote -> Either ByronVoteError ByronVote
forall a b. b -> Either a b
Right Maybe ByronVote
mVote