{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.CLI.EraBased.Transaction.Internal.HashCheck
  ( checkCertificateHashes
  , checkVotingProcedureHashes
  , checkProposalHashes
  )
where

import Cardano.Api
  ( ExceptT
  , Proposal (..)
  , VotingProcedures (..)
  , convert
  , except
  , firstExceptT
  , getAnchorDataFromCertificate
  , getAnchorDataFromGovernanceAction
  , shelleyBasedEraConstraints
  , withExceptT
  )
import Cardano.Api.Experimental qualified as Exp
import Cardano.Api.Ledger qualified as L

import Cardano.CLI.EraIndependent.Hash.Internal.Common (carryHashChecks)
import Cardano.CLI.Type.Common (MustCheckHash (..), PotentiallyCheckedAnchor (..))
import Cardano.CLI.Type.Error.TxCmdError (TxCmdError (..))

import Control.Monad (forM_)

-- | Check the hash of the anchor data against the hash in the anchor
checkAnchorMetadataHash :: L.Anchor -> ExceptT TxCmdError IO ()
checkAnchorMetadataHash :: Anchor -> ExceptT TxCmdError IO ()
checkAnchorMetadataHash Anchor
anchor =
  (HashCheckError -> TxCmdError)
-> ExceptT HashCheckError IO () -> ExceptT TxCmdError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (Url -> HashCheckError -> TxCmdError
TxCmdHashCheckError (Url -> HashCheckError -> TxCmdError)
-> Url -> HashCheckError -> TxCmdError
forall a b. (a -> b) -> a -> b
$ Anchor -> Url
L.anchorUrl Anchor
anchor) (ExceptT HashCheckError IO () -> ExceptT TxCmdError IO ())
-> ExceptT HashCheckError IO () -> ExceptT TxCmdError IO ()
forall a b. (a -> b) -> a -> b
$
    PotentiallyCheckedAnchor Any Anchor -> ExceptT HashCheckError IO ()
forall anchorType.
PotentiallyCheckedAnchor anchorType Anchor
-> ExceptT HashCheckError IO ()
carryHashChecks
      ( PotentiallyCheckedAnchor
          { pcaMustCheck :: MustCheckHash Any
pcaMustCheck = MustCheckHash Any
forall a. MustCheckHash a
CheckHash
          , pcaAnchor :: Anchor
pcaAnchor = Anchor
anchor
          }
      )

-- | Find references to anchor data and check the hashes are valid
-- and they match the linked data.
checkCertificateHashes
  :: Exp.IsEra era => Exp.Certificate (Exp.LedgerEra era) -> ExceptT TxCmdError IO ()
checkCertificateHashes :: forall era.
IsEra era =>
Certificate (LedgerEra era) -> ExceptT TxCmdError IO ()
checkCertificateHashes Certificate (LedgerEra era)
cert = do
  Maybe Anchor
mAnchor <-
    (AnchorDataFromCertificateError -> TxCmdError)
-> ExceptT AnchorDataFromCertificateError IO (Maybe Anchor)
-> ExceptT TxCmdError IO (Maybe Anchor)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
withExceptT AnchorDataFromCertificateError -> TxCmdError
TxCmdPoolMetadataHashError (ExceptT AnchorDataFromCertificateError IO (Maybe Anchor)
 -> ExceptT TxCmdError IO (Maybe Anchor))
-> ExceptT AnchorDataFromCertificateError IO (Maybe Anchor)
-> ExceptT TxCmdError IO (Maybe Anchor)
forall a b. (a -> b) -> a -> b
$
      Either AnchorDataFromCertificateError (Maybe Anchor)
-> ExceptT AnchorDataFromCertificateError IO (Maybe Anchor)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either AnchorDataFromCertificateError (Maybe Anchor)
 -> ExceptT AnchorDataFromCertificateError IO (Maybe Anchor))
-> Either AnchorDataFromCertificateError (Maybe Anchor)
-> ExceptT AnchorDataFromCertificateError IO (Maybe Anchor)
forall a b. (a -> b) -> a -> b
$
        Certificate era
-> Either AnchorDataFromCertificateError (Maybe Anchor)
forall era.
Certificate era
-> Either AnchorDataFromCertificateError (Maybe Anchor)
getAnchorDataFromCertificate (Certificate era
 -> Either AnchorDataFromCertificateError (Maybe Anchor))
-> Certificate era
-> Either AnchorDataFromCertificateError (Maybe Anchor)
forall a b. (a -> b) -> a -> b
$
          Era era -> Certificate (LedgerEra era) -> Certificate era
forall era.
Era era -> Certificate (LedgerEra era) -> Certificate era
Exp.convertToOldApiCertificate Era era
forall era. IsEra era => Era era
Exp.useEra Certificate (LedgerEra era)
cert
  ExceptT TxCmdError IO ()
-> (Anchor -> ExceptT TxCmdError IO ())
-> Maybe Anchor
-> ExceptT TxCmdError IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ExceptT TxCmdError IO ()
forall a. a -> ExceptT TxCmdError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall a. Monoid a => a
mempty) Anchor -> ExceptT TxCmdError IO ()
checkAnchorMetadataHash Maybe Anchor
mAnchor

-- | Find references to anchor data in voting procedures and check the hashes are valid
-- and they match the linked data.
checkVotingProcedureHashes
  :: forall era. Exp.IsEra era => VotingProcedures era -> ExceptT TxCmdError IO ()
checkVotingProcedureHashes :: forall era.
IsEra era =>
VotingProcedures era -> ExceptT TxCmdError IO ()
checkVotingProcedureHashes (VotingProcedures (L.VotingProcedures Map
  Voter (Map GovActionId (VotingProcedure (ShelleyLedgerEra era)))
voterMap)) =
  ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era => ExceptT TxCmdError IO ())
-> ExceptT TxCmdError IO ()
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints (Era era -> ShelleyBasedEra era
forall era. Era era -> ShelleyBasedEra era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert (Era era -> ShelleyBasedEra era) -> Era era -> ShelleyBasedEra era
forall a b. (a -> b) -> a -> b
$ forall era. IsEra era => Era era
Exp.useEra @era) ((ShelleyBasedEraConstraints era => ExceptT TxCmdError IO ())
 -> ExceptT TxCmdError IO ())
-> (ShelleyBasedEraConstraints era => ExceptT TxCmdError IO ())
-> ExceptT TxCmdError IO ()
forall a b. (a -> b) -> a -> b
$
    Map
  Voter (Map GovActionId (VotingProcedure (ShelleyLedgerEra era)))
-> (Map GovActionId (VotingProcedure (ShelleyLedgerEra era))
    -> ExceptT TxCmdError IO (Map GovActionId ()))
-> ExceptT TxCmdError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
      Map
  Voter (Map GovActionId (VotingProcedure (ShelleyLedgerEra era)))
voterMap
      ( (VotingProcedure (ShelleyLedgerEra era)
 -> ExceptT TxCmdError IO ())
-> Map GovActionId (VotingProcedure (ShelleyLedgerEra era))
-> ExceptT TxCmdError IO (Map GovActionId ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map GovActionId a -> m (Map GovActionId b)
mapM ((VotingProcedure (ShelleyLedgerEra era)
  -> ExceptT TxCmdError IO ())
 -> Map GovActionId (VotingProcedure (ShelleyLedgerEra era))
 -> ExceptT TxCmdError IO (Map GovActionId ()))
-> (VotingProcedure (ShelleyLedgerEra era)
    -> ExceptT TxCmdError IO ())
-> Map GovActionId (VotingProcedure (ShelleyLedgerEra era))
-> ExceptT TxCmdError IO (Map GovActionId ())
forall a b. (a -> b) -> a -> b
$ \(L.VotingProcedure Vote
_ StrictMaybe Anchor
mAnchor) ->
          StrictMaybe Anchor
-> (Anchor -> ExceptT TxCmdError IO ()) -> ExceptT TxCmdError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ StrictMaybe Anchor
mAnchor Anchor -> ExceptT TxCmdError IO ()
checkAnchorMetadataHash
      )

-- | Find references to anchor data in proposals and check the hashes are valid
-- and they match the linked data.
checkProposalHashes
  :: forall era. Exp.IsEra era => Proposal era -> ExceptT TxCmdError IO ()
checkProposalHashes :: forall era. IsEra era => Proposal era -> ExceptT TxCmdError IO ()
checkProposalHashes
  ( Proposal
      ( L.ProposalProcedure
          { pProcGovAction :: forall era. ProposalProcedure era -> GovAction era
L.pProcGovAction = GovAction (ShelleyLedgerEra era)
govAction
          , pProcAnchor :: forall era. ProposalProcedure era -> Anchor
L.pProcAnchor = Anchor
anchor
          }
        )
    ) =
    Era era
-> (EraCommonConstraints era => ExceptT TxCmdError IO ())
-> ExceptT TxCmdError IO ()
forall era a. Era era -> (EraCommonConstraints era => a) -> a
Exp.obtainCommonConstraints (forall era. IsEra era => Era era
Exp.useEra @era) ((EraCommonConstraints era => ExceptT TxCmdError IO ())
 -> ExceptT TxCmdError IO ())
-> (EraCommonConstraints era => ExceptT TxCmdError IO ())
-> ExceptT TxCmdError IO ()
forall a b. (a -> b) -> a -> b
$ do
      Anchor -> ExceptT TxCmdError IO ()
checkAnchorMetadataHash Anchor
anchor
      ExceptT TxCmdError IO ()
-> (Anchor -> ExceptT TxCmdError IO ())
-> Maybe Anchor
-> ExceptT TxCmdError IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ExceptT TxCmdError IO ()
forall a. a -> ExceptT TxCmdError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Anchor -> ExceptT TxCmdError IO ()
checkAnchorMetadataHash (GovAction (ShelleyLedgerEra era) -> Maybe Anchor
forall era. GovAction (ShelleyLedgerEra era) -> Maybe Anchor
getAnchorDataFromGovernanceAction GovAction (ShelleyLedgerEra era)
govAction)

-- Only the `NewConstitution` governance action contains a checkable hash with a corresponding URL.