{-# LANGUAGE ScopedTypeVariables #-}

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

import           Cardano.Api (Certificate (..), ExceptT, except, firstExceptT,
                   getAnchorDataFromCertificate, getAnchorDataFromGovernanceAction, withExceptT)
import qualified Cardano.Api.Ledger as L
import qualified Cardano.Api.Shelley as Shelley

import           Cardano.CLI.Run.Hash (carryHashChecks)
import           Cardano.CLI.Types.Common (MustCheckHash (..), PotentiallyCheckedAnchor (..))
import           Cardano.CLI.Types.Errors.TxCmdError (TxCmdError (..))

import           Control.Monad (forM_)

-- | Check the hash of the anchor data against the hash in the anchor
checkAnchorMetadataHash :: L.Anchor L.StandardCrypto -> ExceptT TxCmdError IO ()
checkAnchorMetadataHash :: Anchor StandardCrypto -> ExceptT TxCmdError IO ()
checkAnchorMetadataHash Anchor StandardCrypto
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 StandardCrypto -> Url
forall c. Anchor c -> Url
L.anchorUrl Anchor StandardCrypto
anchor) (ExceptT HashCheckError IO () -> ExceptT TxCmdError IO ())
-> ExceptT HashCheckError IO () -> ExceptT TxCmdError IO ()
forall a b. (a -> b) -> a -> b
$
    PotentiallyCheckedAnchor Any (Anchor StandardCrypto)
-> ExceptT HashCheckError IO ()
forall anchorType.
PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
-> ExceptT HashCheckError IO ()
carryHashChecks
      ( PotentiallyCheckedAnchor
          { pcaMustCheck :: MustCheckHash Any
pcaMustCheck = MustCheckHash Any
forall a. MustCheckHash a
CheckHash
          , pcaAnchor :: Anchor StandardCrypto
pcaAnchor = Anchor StandardCrypto
anchor
          }
      )

-- | Find references to anchor data and check the hashes are valid
-- and they match the linked data.
checkCertificateHashes :: Certificate era -> ExceptT TxCmdError IO ()
checkCertificateHashes :: forall era. Certificate era -> ExceptT TxCmdError IO ()
checkCertificateHashes Certificate era
cert = do
  Maybe (Anchor StandardCrypto)
mAnchor <- (AnchorDataFromCertificateError -> TxCmdError)
-> ExceptT
     AnchorDataFromCertificateError IO (Maybe (Anchor StandardCrypto))
-> ExceptT TxCmdError IO (Maybe (Anchor StandardCrypto))
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 StandardCrypto))
 -> ExceptT TxCmdError IO (Maybe (Anchor StandardCrypto)))
-> ExceptT
     AnchorDataFromCertificateError IO (Maybe (Anchor StandardCrypto))
-> ExceptT TxCmdError IO (Maybe (Anchor StandardCrypto))
forall a b. (a -> b) -> a -> b
$ Either
  AnchorDataFromCertificateError (Maybe (Anchor StandardCrypto))
-> ExceptT
     AnchorDataFromCertificateError IO (Maybe (Anchor StandardCrypto))
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either
   AnchorDataFromCertificateError (Maybe (Anchor StandardCrypto))
 -> ExceptT
      AnchorDataFromCertificateError IO (Maybe (Anchor StandardCrypto)))
-> Either
     AnchorDataFromCertificateError (Maybe (Anchor StandardCrypto))
-> ExceptT
     AnchorDataFromCertificateError IO (Maybe (Anchor StandardCrypto))
forall a b. (a -> b) -> a -> b
$ Certificate era
-> Either
     AnchorDataFromCertificateError (Maybe (Anchor StandardCrypto))
forall era.
Certificate era
-> Either
     AnchorDataFromCertificateError (Maybe (Anchor StandardCrypto))
getAnchorDataFromCertificate Certificate era
cert
  ExceptT TxCmdError IO ()
-> (Anchor StandardCrypto -> ExceptT TxCmdError IO ())
-> Maybe (Anchor StandardCrypto)
-> 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 StandardCrypto -> ExceptT TxCmdError IO ()
checkAnchorMetadataHash Maybe (Anchor StandardCrypto)
mAnchor

-- | Find references to anchor data in voting procedures and check the hashes are valid
-- and they match the linked data.
checkVotingProcedureHashes
  :: Shelley.ShelleyBasedEra era -> Shelley.VotingProcedures era -> ExceptT TxCmdError IO ()
checkVotingProcedureHashes :: forall era.
ShelleyBasedEra era
-> VotingProcedures era -> ExceptT TxCmdError IO ()
checkVotingProcedureHashes ShelleyBasedEra era
eon (Shelley.VotingProcedures (L.VotingProcedures Map
  (Voter (EraCrypto (ShelleyLedgerEra era)))
  (Map
     (GovActionId (EraCrypto (ShelleyLedgerEra era)))
     (VotingProcedure (ShelleyLedgerEra era)))
voterMap)) =
  ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era => ExceptT TxCmdError IO ())
-> ExceptT TxCmdError IO ()
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
Shelley.shelleyBasedEraConstraints ShelleyBasedEra era
eon ((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 StandardCrypto)
  (Map
     (GovActionId StandardCrypto)
     (VotingProcedure (ShelleyLedgerEra era)))
-> (Map
      (GovActionId StandardCrypto)
      (VotingProcedure (ShelleyLedgerEra era))
    -> ExceptT TxCmdError IO (Map (GovActionId StandardCrypto) ()))
-> ExceptT TxCmdError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
      Map
  (Voter (EraCrypto (ShelleyLedgerEra era)))
  (Map
     (GovActionId (EraCrypto (ShelleyLedgerEra era)))
     (VotingProcedure (ShelleyLedgerEra era)))
Map
  (Voter StandardCrypto)
  (Map
     (GovActionId StandardCrypto)
     (VotingProcedure (ShelleyLedgerEra era)))
voterMap
      ( (VotingProcedure (ShelleyLedgerEra era)
 -> ExceptT TxCmdError IO ())
-> Map
     (GovActionId StandardCrypto)
     (VotingProcedure (ShelleyLedgerEra era))
-> ExceptT TxCmdError IO (Map (GovActionId StandardCrypto) ())
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 StandardCrypto) a
-> m (Map (GovActionId StandardCrypto) b)
mapM ((VotingProcedure (ShelleyLedgerEra era)
  -> ExceptT TxCmdError IO ())
 -> Map
      (GovActionId StandardCrypto)
      (VotingProcedure (ShelleyLedgerEra era))
 -> ExceptT TxCmdError IO (Map (GovActionId StandardCrypto) ()))
-> (VotingProcedure (ShelleyLedgerEra era)
    -> ExceptT TxCmdError IO ())
-> Map
     (GovActionId StandardCrypto)
     (VotingProcedure (ShelleyLedgerEra era))
-> ExceptT TxCmdError IO (Map (GovActionId StandardCrypto) ())
forall a b. (a -> b) -> a -> b
$ \(L.VotingProcedure Vote
_ StrictMaybe (Anchor (EraCrypto (ShelleyLedgerEra era)))
mAnchor) ->
          StrictMaybe (Anchor StandardCrypto)
-> (Anchor StandardCrypto -> ExceptT TxCmdError IO ())
-> ExceptT TxCmdError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ StrictMaybe (Anchor (EraCrypto (ShelleyLedgerEra era)))
StrictMaybe (Anchor StandardCrypto)
mAnchor Anchor StandardCrypto -> 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. Shelley.ShelleyBasedEra era -> Shelley.Proposal era -> ExceptT TxCmdError IO ()
checkProposalHashes :: forall era.
ShelleyBasedEra era -> Proposal era -> ExceptT TxCmdError IO ()
checkProposalHashes
  ShelleyBasedEra era
eon
  ( Shelley.Proposal
      ( L.ProposalProcedure
          { pProcGovAction :: forall era. ProposalProcedure era -> GovAction era
L.pProcGovAction = GovAction (ShelleyLedgerEra era)
govAction
          , pProcAnchor :: forall era. ProposalProcedure era -> Anchor (EraCrypto era)
L.pProcAnchor = Anchor (EraCrypto (ShelleyLedgerEra era))
anchor
          }
        )
    ) =
    ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era => ExceptT TxCmdError IO ())
-> ExceptT TxCmdError IO ()
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
Shelley.shelleyBasedEraConstraints ShelleyBasedEra era
eon ((ShelleyBasedEraConstraints era => ExceptT TxCmdError IO ())
 -> ExceptT TxCmdError IO ())
-> (ShelleyBasedEraConstraints era => ExceptT TxCmdError IO ())
-> ExceptT TxCmdError IO ()
forall a b. (a -> b) -> a -> b
$ do
      Anchor StandardCrypto -> ExceptT TxCmdError IO ()
checkAnchorMetadataHash Anchor (EraCrypto (ShelleyLedgerEra era))
Anchor StandardCrypto
anchor
      ExceptT TxCmdError IO ()
-> (Anchor StandardCrypto -> ExceptT TxCmdError IO ())
-> Maybe (Anchor StandardCrypto)
-> 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 StandardCrypto -> ExceptT TxCmdError IO ()
checkAnchorMetadataHash (GovAction (ShelleyLedgerEra era) -> Maybe (Anchor StandardCrypto)
forall era.
(EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) =>
GovAction (ShelleyLedgerEra era) -> Maybe (Anchor StandardCrypto)
getAnchorDataFromGovernanceAction GovAction (ShelleyLedgerEra era)
govAction)

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