{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Cardano.CLI.EraBased.Governance.Vote.Run
  ( runGovernanceVoteCmds
  )
where

import Cardano.Api
import Cardano.Api.Experimental (obtainCommonConstraints)
import Cardano.Api.Ledger qualified as L

import Cardano.CLI.Compatible.Exception
import Cardano.CLI.EraBased.Governance.Vote.Command qualified as Cmd
import Cardano.CLI.EraBased.Script.Vote.Read
import Cardano.CLI.EraIndependent.Hash.Internal.Common (carryHashChecks)
import Cardano.CLI.Json.Encode qualified as Json
import Cardano.CLI.Orphan ()
import Cardano.CLI.Read (getHashFromStakePoolKeyHashSource)
import Cardano.CLI.Type.Common
import Cardano.CLI.Type.Governance
import Cardano.CLI.Type.Key

import Data.Function
import Vary qualified

runGovernanceVoteCmds
  :: ()
  => Cmd.GovernanceVoteCmds era
  -> CIO e ()
runGovernanceVoteCmds :: forall era e. GovernanceVoteCmds era -> CIO e ()
runGovernanceVoteCmds = \case
  Cmd.GovernanceVoteCreateCmd GovernanceVoteCreateCmdArgs era
args ->
    GovernanceVoteCreateCmdArgs era -> CIO e ()
forall era e. GovernanceVoteCreateCmdArgs era -> CIO e ()
runGovernanceVoteCreateCmd GovernanceVoteCreateCmdArgs era
args
  Cmd.GovernanceVoteViewCmd GovernanceVoteViewCmdArgs era
args ->
    GovernanceVoteViewCmdArgs era -> CIO e ()
forall era e. GovernanceVoteViewCmdArgs era -> CIO e ()
runGovernanceVoteViewCmd GovernanceVoteViewCmdArgs era
args

runGovernanceVoteCreateCmd
  :: forall era e
   . ()
  => Cmd.GovernanceVoteCreateCmdArgs era
  -> CIO e ()
runGovernanceVoteCreateCmd :: forall era e. GovernanceVoteCreateCmdArgs era -> CIO e ()
runGovernanceVoteCreateCmd
  Cmd.GovernanceVoteCreateCmdArgs
    { Era era
era :: Era era
era :: forall era. GovernanceVoteCreateCmdArgs era -> Era era
era
    , Vote
voteChoice :: Vote
voteChoice :: forall era. GovernanceVoteCreateCmdArgs era -> Vote
voteChoice
    , GovActionId
governanceActionId :: GovActionId
governanceActionId :: forall era. GovernanceVoteCreateCmdArgs era -> GovActionId
governanceActionId
    , AnyVotingStakeVerificationKeyOrHashOrFile
votingStakeCredentialSource :: AnyVotingStakeVerificationKeyOrHashOrFile
votingStakeCredentialSource :: forall era.
GovernanceVoteCreateCmdArgs era
-> AnyVotingStakeVerificationKeyOrHashOrFile
votingStakeCredentialSource
    , Maybe
  (PotentiallyCheckedAnchor VoteUrl (VoteUrl, SafeHash AnchorData))
mAnchor :: Maybe
  (PotentiallyCheckedAnchor VoteUrl (VoteUrl, SafeHash AnchorData))
mAnchor :: forall era.
GovernanceVoteCreateCmdArgs era
-> Maybe
     (PotentiallyCheckedAnchor VoteUrl (VoteUrl, SafeHash AnchorData))
mAnchor
    , VoteFile 'Out
outFile :: VoteFile 'Out
outFile :: forall era. GovernanceVoteCreateCmdArgs era -> VoteFile 'Out
outFile
    } = do
    let sbe :: ConwayEraOnwards era
sbe = Era era -> ConwayEraOnwards era
forall era. Era era -> ConwayEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
era -- TODO: Conway era - update vote creation related function to take ConwayEraOnwards
        mAnchor' :: Maybe (PotentiallyCheckedAnchor VoteUrl Anchor)
mAnchor' =
          (PotentiallyCheckedAnchor VoteUrl (VoteUrl, SafeHash AnchorData)
 -> PotentiallyCheckedAnchor VoteUrl Anchor)
-> Maybe
     (PotentiallyCheckedAnchor VoteUrl (VoteUrl, SafeHash AnchorData))
-> Maybe (PotentiallyCheckedAnchor VoteUrl Anchor)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ( \pca :: PotentiallyCheckedAnchor VoteUrl (VoteUrl, SafeHash AnchorData)
pca@PotentiallyCheckedAnchor{pcaAnchor :: forall anchorType anchor.
PotentiallyCheckedAnchor anchorType anchor -> anchor
pcaAnchor = (VoteUrl Url
url, SafeHash AnchorData
voteHash)} ->
                PotentiallyCheckedAnchor VoteUrl (VoteUrl, SafeHash AnchorData)
pca{pcaAnchor = L.Anchor{L.anchorUrl = url, L.anchorDataHash = voteHash}}
            )
            Maybe
  (PotentiallyCheckedAnchor VoteUrl (VoteUrl, SafeHash AnchorData))
mAnchor

    (PotentiallyCheckedAnchor VoteUrl Anchor -> RIO e ())
-> Maybe (PotentiallyCheckedAnchor VoteUrl Anchor) -> RIO e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      (ExceptT HashCheckError IO () -> RIO e ()
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
ExceptT e IO a -> m a
fromExceptTCli (ExceptT HashCheckError IO () -> RIO e ())
-> (PotentiallyCheckedAnchor VoteUrl Anchor
    -> ExceptT HashCheckError IO ())
-> PotentiallyCheckedAnchor VoteUrl Anchor
-> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PotentiallyCheckedAnchor VoteUrl Anchor
-> ExceptT HashCheckError IO ()
forall anchorType.
PotentiallyCheckedAnchor anchorType Anchor
-> ExceptT HashCheckError IO ()
carryHashChecks)
      Maybe (PotentiallyCheckedAnchor VoteUrl Anchor)
mAnchor'

    VotingProcedure era
voteProcedure <- case Maybe (PotentiallyCheckedAnchor VoteUrl Anchor)
mAnchor' of
      Maybe (PotentiallyCheckedAnchor VoteUrl Anchor)
Nothing -> VotingProcedure era -> RIO e (VotingProcedure era)
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VotingProcedure era -> RIO e (VotingProcedure era))
-> VotingProcedure era -> RIO e (VotingProcedure era)
forall a b. (a -> b) -> a -> b
$ ConwayEraOnwards era
-> Vote -> Maybe (Url, Text) -> VotingProcedure era
forall era.
ConwayEraOnwards era
-> Vote -> Maybe (Url, Text) -> VotingProcedure era
createVotingProcedure ConwayEraOnwards era
sbe Vote
voteChoice Maybe (Url, Text)
forall a. Maybe a
Nothing
      Just PotentiallyCheckedAnchor VoteUrl Anchor
voteAnchor ->
        let VotingProcedure VotingProcedure (ShelleyLedgerEra era)
votingProcedureWithoutAnchor = ConwayEraOnwards era
-> Vote -> Maybe (Url, Text) -> VotingProcedure era
forall era.
ConwayEraOnwards era
-> Vote -> Maybe (Url, Text) -> VotingProcedure era
createVotingProcedure (Era era -> ConwayEraOnwards era
forall era. Era era -> ConwayEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
era) Vote
voteChoice Maybe (Url, Text)
forall a. Maybe a
Nothing
            votingProcedureWithAnchor :: VotingProcedure era
votingProcedureWithAnchor = VotingProcedure (ShelleyLedgerEra era) -> VotingProcedure era
forall era.
VotingProcedure (ShelleyLedgerEra era) -> VotingProcedure era
VotingProcedure (VotingProcedure (ShelleyLedgerEra era) -> VotingProcedure era)
-> VotingProcedure (ShelleyLedgerEra era) -> VotingProcedure era
forall a b. (a -> b) -> a -> b
$ VotingProcedure (ShelleyLedgerEra era)
votingProcedureWithoutAnchor{L.vProcAnchor = L.SJust (pcaAnchor voteAnchor)}
         in VotingProcedure era -> RIO e (VotingProcedure era)
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return VotingProcedure era
votingProcedureWithAnchor

    Voter
voter <- case AnyVotingStakeVerificationKeyOrHashOrFile
votingStakeCredentialSource of
      AnyDRepVerificationKeyOrHashOrFileOrScriptHash VerificationKeyOrHashOrFileOrScriptHash DRepKey
stake -> do
        Credential 'DRepRole -> Voter
L.DRepVoter (Credential 'DRepRole -> Voter)
-> RIO e (Credential 'DRepRole) -> RIO e Voter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Hash DRepKey -> KeyHash 'DRepRole)
-> VerificationKeyOrHashOrFileOrScriptHash DRepKey
-> CIO e (Credential 'DRepRole)
forall keyrole (kr :: KeyRole) e.
Key keyrole =>
(Hash keyrole -> KeyHash kr)
-> VerificationKeyOrHashOrFileOrScriptHash keyrole
-> CIO e (Credential kr)
readVerificationKeyOrHashOrFileOrScriptHash Hash DRepKey -> KeyHash 'DRepRole
unDRepKeyHash VerificationKeyOrHashOrFileOrScriptHash DRepKey
stake
      AnyStakePoolVerificationKeyOrHashOrFile StakePoolKeyHashSource
stake -> do
        StakePoolKeyHash KeyHash 'StakePool
h <-
          IO (Hash StakePoolKey) -> RIO e (Hash StakePoolKey)
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Hash StakePoolKey) -> RIO e (Hash StakePoolKey))
-> IO (Hash StakePoolKey) -> RIO e (Hash StakePoolKey)
forall a b. (a -> b) -> a -> b
$ StakePoolKeyHashSource -> IO (Hash StakePoolKey)
forall (m :: * -> *).
MonadIO m =>
StakePoolKeyHashSource -> m (Hash StakePoolKey)
getHashFromStakePoolKeyHashSource StakePoolKeyHashSource
stake
        Voter -> RIO e Voter
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Voter -> RIO e Voter) -> Voter -> RIO e Voter
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> Voter
L.StakePoolVoter KeyHash 'StakePool
h
      AnyCommitteeHotVerificationKeyOrHashOrFileOrScriptHash VerificationKeyOrHashOrFileOrScriptHash CommitteeHotKey
stake ->
        Credential 'HotCommitteeRole -> Voter
L.CommitteeVoter (Credential 'HotCommitteeRole -> Voter)
-> RIO e (Credential 'HotCommitteeRole) -> RIO e Voter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Hash CommitteeHotKey -> KeyHash 'HotCommitteeRole)
-> VerificationKeyOrHashOrFileOrScriptHash CommitteeHotKey
-> CIO e (Credential 'HotCommitteeRole)
forall keyrole (kr :: KeyRole) e.
Key keyrole =>
(Hash keyrole -> KeyHash kr)
-> VerificationKeyOrHashOrFileOrScriptHash keyrole
-> CIO e (Credential kr)
readVerificationKeyOrHashOrFileOrScriptHash Hash CommitteeHotKey -> KeyHash 'HotCommitteeRole
unCommitteeHotKeyHash VerificationKeyOrHashOrFileOrScriptHash CommitteeHotKey
stake

    let votingProcedures :: VotingProcedures era
votingProcedures =
          ConwayEraOnwards era
-> Voter
-> GovActionId
-> VotingProcedure (ShelleyLedgerEra era)
-> VotingProcedures era
forall era.
ConwayEraOnwards era
-> Voter
-> GovActionId
-> VotingProcedure (ShelleyLedgerEra era)
-> VotingProcedures era
singletonVotingProcedures (Era era -> ConwayEraOnwards era
forall era. Era era -> ConwayEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
era) Voter
voter GovActionId
governanceActionId (VotingProcedure era -> VotingProcedure (ShelleyLedgerEra era)
forall era.
VotingProcedure era -> VotingProcedure (ShelleyLedgerEra era)
unVotingProcedure VotingProcedure era
voteProcedure)
    Era era -> (EraCommonConstraints era => RIO e ()) -> RIO e ()
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => RIO e ()) -> RIO e ())
-> (EraCommonConstraints era => RIO e ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$
      IO (Either (FileError ()) ()) -> RIO e ()
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli (IO (Either (FileError ()) ()) -> RIO e ())
-> IO (Either (FileError ()) ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$
        VoteFile 'Out
-> Maybe TextEnvelopeDescr
-> VotingProcedures era
-> IO (Either (FileError ()) ())
forall a content.
HasTextEnvelope a =>
File content 'Out
-> Maybe TextEnvelopeDescr -> a -> IO (Either (FileError ()) ())
writeFileTextEnvelope VoteFile 'Out
outFile Maybe TextEnvelopeDescr
forall a. Maybe a
Nothing VotingProcedures era
votingProcedures

runGovernanceVoteViewCmd
  :: forall era e
   . ()
  => Cmd.GovernanceVoteViewCmdArgs era
  -> CIO e ()
runGovernanceVoteViewCmd :: forall era e. GovernanceVoteViewCmdArgs era -> CIO e ()
runGovernanceVoteViewCmd
  Cmd.GovernanceVoteViewCmdArgs
    { Era era
era :: Era era
era :: forall era. GovernanceVoteViewCmdArgs era -> Era era
era
    , VoteFile 'In
voteFile :: VoteFile 'In
voteFile :: forall era. GovernanceVoteViewCmdArgs era -> VoteFile 'In
voteFile
    , Vary '[FormatJson, FormatYaml]
outputFormat :: Vary '[FormatJson, FormatYaml]
outputFormat :: forall era.
GovernanceVoteViewCmdArgs era -> Vary '[FormatJson, FormatYaml]
outputFormat
    , Maybe (File () 'Out)
mOutFile :: Maybe (File () 'Out)
mOutFile :: forall era. GovernanceVoteViewCmdArgs era -> Maybe (File () 'Out)
mOutFile
    } = do
    Era era -> (EraCommonConstraints era => RIO e ()) -> RIO e ()
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => RIO e ()) -> RIO e ())
-> (EraCommonConstraints era => RIO e ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ do
      VotingProcedures era
voteProcedures <- (VotingProcedures era, Maybe (VoteScriptWitness era))
-> VotingProcedures era
forall a b. (a, b) -> a
fst ((VotingProcedures era, Maybe (VoteScriptWitness era))
 -> VotingProcedures era)
-> RIO e (VotingProcedures era, Maybe (VoteScriptWitness era))
-> RIO e (VotingProcedures era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConwayEraOnwards era
-> (VoteFile 'In, Maybe (ScriptRequirements 'VoterItem))
-> CIO e (VotingProcedures era, Maybe (VoteScriptWitness era))
forall era e.
ConwayEraOnwards era
-> (VoteFile 'In, Maybe (ScriptRequirements 'VoterItem))
-> CIO e (VotingProcedures era, Maybe (VoteScriptWitness era))
readVoteScriptWitness (Era era -> ConwayEraOnwards era
forall era. Era era -> ConwayEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
era) (VoteFile 'In
voteFile, Maybe (ScriptRequirements 'VoterItem)
forall a. Maybe a
Nothing)

      let output :: ByteString
output =
            Vary '[FormatJson, FormatYaml]
outputFormat
              Vary '[FormatJson, FormatYaml]
-> (Vary '[FormatJson, FormatYaml]
    -> VotingProcedures (LedgerEra era) -> ByteString)
-> VotingProcedures (LedgerEra era)
-> ByteString
forall a b. a -> (a -> b) -> b
& ( (Vary '[FormatJson, FormatYaml]
 -> VotingProcedures (LedgerEra era) -> ByteString)
-> Vary '[FormatJson, FormatYaml]
-> VotingProcedures (LedgerEra era)
-> ByteString
forall a. a -> a
id
                    ((Vary '[FormatJson, FormatYaml]
  -> VotingProcedures (LedgerEra era) -> ByteString)
 -> Vary '[FormatJson, FormatYaml]
 -> VotingProcedures (LedgerEra era)
 -> ByteString)
-> ((Vary '[] -> VotingProcedures (LedgerEra era) -> ByteString)
    -> Vary '[FormatJson, FormatYaml]
    -> VotingProcedures (LedgerEra era)
    -> ByteString)
-> (Vary '[] -> VotingProcedures (LedgerEra era) -> ByteString)
-> Vary '[FormatJson, FormatYaml]
-> VotingProcedures (LedgerEra era)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FormatJson -> VotingProcedures (LedgerEra era) -> ByteString)
-> (Vary '[FormatYaml]
    -> VotingProcedures (LedgerEra era) -> ByteString)
-> Vary '[FormatJson, FormatYaml]
-> VotingProcedures (LedgerEra era)
-> ByteString
forall a b (l :: [*]).
(a -> b) -> (Vary l -> b) -> Vary (a : l) -> b
Vary.on (\FormatJson
FormatJson -> VotingProcedures (LedgerEra era) -> ByteString
forall a. ToJSON a => a -> ByteString
Json.encodeJson)
                    ((Vary '[FormatYaml]
  -> VotingProcedures (LedgerEra era) -> ByteString)
 -> Vary '[FormatJson, FormatYaml]
 -> VotingProcedures (LedgerEra era)
 -> ByteString)
-> ((Vary '[] -> VotingProcedures (LedgerEra era) -> ByteString)
    -> Vary '[FormatYaml]
    -> VotingProcedures (LedgerEra era)
    -> ByteString)
-> (Vary '[] -> VotingProcedures (LedgerEra era) -> ByteString)
-> Vary '[FormatJson, FormatYaml]
-> VotingProcedures (LedgerEra era)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FormatYaml -> VotingProcedures (LedgerEra era) -> ByteString)
-> (Vary '[] -> VotingProcedures (LedgerEra era) -> ByteString)
-> Vary '[FormatYaml]
-> VotingProcedures (LedgerEra era)
-> ByteString
forall a b (l :: [*]).
(a -> b) -> (Vary l -> b) -> Vary (a : l) -> b
Vary.on (\FormatYaml
FormatYaml -> VotingProcedures (LedgerEra era) -> ByteString
forall a. ToJSON a => a -> ByteString
Json.encodeYaml)
                    ((Vary '[] -> VotingProcedures (LedgerEra era) -> ByteString)
 -> Vary '[FormatJson, FormatYaml]
 -> VotingProcedures (LedgerEra era)
 -> ByteString)
-> (Vary '[] -> VotingProcedures (LedgerEra era) -> ByteString)
-> Vary '[FormatJson, FormatYaml]
-> VotingProcedures (LedgerEra era)
-> ByteString
forall a b. (a -> b) -> a -> b
$ Vary '[] -> VotingProcedures (LedgerEra era) -> ByteString
forall anything. Vary '[] -> anything
Vary.exhaustiveCase
                )
              (VotingProcedures (LedgerEra era) -> ByteString)
-> VotingProcedures (LedgerEra era) -> ByteString
forall a b. (a -> b) -> a -> b
$ VotingProcedures era -> VotingProcedures (ShelleyLedgerEra era)
forall era.
VotingProcedures era -> VotingProcedures (ShelleyLedgerEra era)
unVotingProcedures VotingProcedures era
voteProcedures

      forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli @(FileError ()) (IO (Either (FileError ()) ()) -> RIO e ())
-> IO (Either (FileError ()) ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ Maybe (File () 'Out) -> ByteString -> IO (Either (FileError ()) ())
forall (m :: * -> *) content e.
MonadIO m =>
Maybe (File content 'Out)
-> ByteString -> m (Either (FileError e) ())
writeLazyByteStringOutput Maybe (File () 'Out)
mOutFile ByteString
output