{-# LANGUAGE TemplateHaskell #-}

{- |
Module     : Agora.Governor
Maintainer : emi@haskell.fyi
Description: Governor entity scripts acting as authority of entire system.

Governor entity scripts acting as authority of entire system.
-}
module Agora.Governor (
  -- * Haskell-land
  GovernorDatum (..),
  GovernorRedeemer (..),
  Governor (..),
  governorStateTokenName,

  -- * Plutarch-land
  PGovernorDatum (..),
  PGovernorRedeemer (..),

  -- * Scripts
  governorPolicy,
  governorValidator,

  -- * Utilities
  governorStateTokenAssetClass,
  authorityTokenSymbolFromGovernor,
) where

--------------------------------------------------------------------------------

import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))

--------------------------------------------------------------------------------

import Agora.AuthorityToken (
  AuthorityToken (..),
  authorityTokenPolicy,
  authorityTokensValidIn,
  singleAuthorityTokenBurned,
 )
import Agora.Proposal (
  PProposalDatum,
  PProposalId,
  PProposalStatus (PDraft),
  PProposalThresholds,
  PProposalVotes (PProposalVotes),
  PResultTag (PResultTag),
  Proposal (..),
  ProposalId,
  ProposalThresholds,
  pnextProposalId,
  proposalDatumValid,
  proposalPolicy,
  proposalValidator,
 )
import Agora.Utils (
  containsSingleCurrencySymbol,
  findOutputsToAddress,
  hasOnlyOneTokenOfCurrencySymbol,
  mustBePDJust,
  mustBePJust,
  mustFindDatum',
  passert,
  passetClassValueOf,
  passetClassValueOf',
  pfindDatum,
  pfindTxInByTxOutRef,
  pisDJust,
  pisUxtoSpent,
  pownCurrencySymbol,
  psymbolValueOf,
  scriptHashFromAddress,
 )

--------------------------------------------------------------------------------

import Plutarch (popaque)
import Plutarch.Api.V1 (
  PAddress,
  PCurrencySymbol,
  PDatumHash,
  PMaybeData (PDJust),
  PMintingPolicy,
  PScriptPurpose (PSpending),
  PValidator,
  PValidatorHash,
  PValue,
  mintingPolicySymbol,
  mkMintingPolicy,
  mkValidator,
  validatorHash,
 )
import Plutarch.Api.V1.Extra (pownMintValue)
import Plutarch.DataRepr (
  DerivePConstantViaData (..),
  PDataFields,
  PIsDataReprInstances (PIsDataReprInstances),
 )
import Plutarch.Lift (PUnsafeLiftDecl (..))
import Plutarch.Monadic qualified as P
import Plutarch.Unsafe (punsafeCoerce)

--------------------------------------------------------------------------------

import Plutarch.Builtin (PBuiltinMap, pforgetData)
import Plutarch.Map.Extra (plookup, plookup')
import Plutus.V1.Ledger.Api (
  Address (Address),
  Credential (ScriptCredential),
  CurrencySymbol (..),
  MintingPolicy,
  TxOutRef,
  Validator,
  ValidatorHash,
 )
import Plutus.V1.Ledger.Value (
  AssetClass (..),
  TokenName (..),
 )
import PlutusTx qualified

--------------------------------------------------------------------------------

-- | Datum for the Governor script.
data GovernorDatum = GovernorDatum
  { proposalThresholds :: ProposalThresholds
  -- ^ Gets copied over upon creation of a 'Agora.Proposal.ProposalDatum'.
  , nextProposalId :: ProposalId
  -- ^ What tag the next proposal will get upon creating.
  }
  deriving stock (Show, GHC.Generic)

PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]

{- | Redeemer for Governor script. The governor has two primary
     responsibilities:

     1. The gating of Proposal creation.
     2. The gating of minting authority tokens.

     Parameters of the governor can also be mutated by an effect.
-}
data GovernorRedeemer
  = -- | Checks that a proposal was created lawfully, and allows it.
    CreateProposal
  | -- | Checks that a SINGLE proposal finished correctly,
    --   and allows minting GATs for each effect script.
    MintGATs
  | -- | Allows effects to mutate the parameters.
    MutateMutateGovernor
  deriving stock (Show, GHC.Generic)

PlutusTx.makeIsDataIndexed
  ''GovernorRedeemer
  [ ('CreateProposal, 0)
  , ('MintGATs, 1)
  , ('MutateMutateGovernor, 2)
  ]

-- | Parameters for creating Governor scripts.
data Governor = Governor
  { stORef :: TxOutRef
  -- ^ An utxo, which will be spent to mint the state token for the governor validator.
  }

governorStateTokenName :: TokenName
governorStateTokenName = TokenName ""

--------------------------------------------------------------------------------

-- | Plutarch-level datum for the Governor script.
newtype PGovernorDatum (s :: S) = PGovernorDatum
  { getGovernorDatum ::
    Term
      s
      ( PDataRecord
          '[ "proposalThresholds" ':= PProposalThresholds
           , "nextProposalId" ':= PProposalId
           ]
      )
  }
  deriving stock (GHC.Generic)
  deriving anyclass (Generic)
  deriving anyclass (PIsDataRepr)
  deriving
    (PlutusType, PIsData, PDataFields)
    via PIsDataReprInstances PGovernorDatum

instance PUnsafeLiftDecl PGovernorDatum where type PLifted PGovernorDatum = GovernorDatum
deriving via (DerivePConstantViaData GovernorDatum PGovernorDatum) instance (PConstant GovernorDatum)

-- | Plutarch-level version of 'GovernorRedeemer'.
data PGovernorRedeemer (s :: S)
  = PCreateProposal (Term s (PDataRecord '[]))
  | PMintGATs (Term s (PDataRecord '[]))
  | PMutateGovernor (Term s (PDataRecord '[]))
  deriving stock (GHC.Generic)
  deriving anyclass (Generic)
  deriving anyclass (PIsDataRepr)
  deriving
    (PlutusType, PIsData)
    via PIsDataReprInstances PGovernorRedeemer

instance PUnsafeLiftDecl PGovernorRedeemer where type PLifted PGovernorRedeemer = GovernorRedeemer
deriving via (DerivePConstantViaData GovernorRedeemer PGovernorRedeemer) instance (PConstant GovernorRedeemer)

--------------------------------------------------------------------------------

{- | Policy for Governors.
   This policy mints a state token for the 'governorValidator'.
   It will check:

    - The utxo specified in the Governor parameter is spent.
    - Only one token is minted.
    - Ensure the token name is "".
-}
governorPolicy :: Governor -> ClosedTerm PMintingPolicy
governorPolicy params =
  plam $ \_ ctx' -> P.do
    ctx <- pletFields @'["txInfo", "purpose"] ctx'
    let oref = pconstant params.stORef
        ownSymbol = pownCurrencySymbol # ctx'

    mintValue <- plet $ pownMintValue # ctx'

    passert "Referenced utxo should be spent" $ pisUxtoSpent # oref # ctx.txInfo

    passert "Exactly one token should be minted" $
      psymbolValueOf # ownSymbol # mintValue #== 1
        #&& passetClassValueOf # ownSymbol # pconstant governorStateTokenName # mintValue #== 1

    passert "Nothing is minted other than the state token" $
      containsSingleCurrencySymbol # mintValue

    popaque (pconstant ())

{- Validator for Governors.

   A state token, minted by 'governorPolicy' is used to identify the datum utxo.

   No matter what redeemer it receives, it will always check:
    - The utxo which has the state token must be spent.
    - The state token always stays at the script address.
    - The utxo which holds the state token, has a well well-formed 'GovernorDatum' datum.

   For 'CreateProposal' redeemer, it will check:
    - Exactly one proposal state token is minted.
    - Exactly one utxo should be sent to the proposal validator.
    - The utxo must contain the proposal state token.
    - The datum of said utxo must be correct.
    - Proposal id in the governor datum must be advanced.

   For 'MintGATs' redeemer, it will check:
    - State datum is not changed.
    - Exactly one proposal is being processed.
    - Mint one GAT for every effect.
    - The GATs is properly tagged. (Should we do this?)
    - The GATs are sent to the appropraite effects. (Should we do this?)

   For 'MutateGovernor', it will check:
    - A GAT is burnt.
    - Said GAT must be tagged by the effect that is spending it.
-}
governorValidator :: Governor -> ClosedTerm PValidator
governorValidator params =
  plam $ \datum' redeemer' ctx' -> P.do
    -- TODO: use ptryFrom
    redeemer <- pmatch $ pfromData @PGovernorRedeemer $ punsafeCoerce redeemer'
    ctx <- pletFields @'["txInfo", "purpose"] ctx'

    txInfo' <- plet $ pfromData $ ctx.txInfo
    txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo'

    PSpending ((pfield @"_0" #) -> txOutRef') <- pmatch $ pfromData ctx.purpose
    let txOutRef = pfromData txOutRef'

    PJust ((pfield @"resolved" #) -> ownInput') <- pmatch $ pfindTxInByTxOutRef # txOutRef # txInfo'
    ownInput <- pletFields @'["address", "value"] ownInput'
    let selfAddress = pfromData $ ownInput.address

    -- TODO: use ptryFrom
    let oldParams' = pfromData @PGovernorDatum $ punsafeCoerce datum'
    oldParams <- pletFields @'["proposalThresholds", "nextProposalId"] oldParams'

    let ownInputDatumNFTAmount = stateTokenValueOf # ownInput.value
    passert "Own input should have exactly one state token" $
      ownInputDatumNFTAmount #== 1

    ownOutputs <- plet $ findOutputsToAddress # txInfo' # selfAddress
    passert "Exactly one utxo should be sent to the governor" $
      plength # ownOutputs #== 1

    ownOutput <- pletFields @'["value", "datumHash"] $ phead # ownOutputs
    let ownOuputDatumNFTAmount = stateTokenValueOf # ownOutput.value
    passert "State token should stay at governor's address" $
      ownOuputDatumNFTAmount #== 1
    passert "Output utxo to governor should have datum" $
      pisDJust # ownOutput.datumHash

    -- TODO: use `PTryFrom` and reject bad datum
    newDatum' <- plet $ mustFindDatum' @PGovernorDatum # ownOutput.datumHash # ctx.txInfo
    newParams <- pletFields @'["proposalThresholds", "nextProposalId"] newDatum'

    case redeemer of
      PCreateProposal _ -> P.do
        passert "Proposal id should be advanced by 1" $
          pnextProposalId # oldParams.nextProposalId #== newParams.nextProposalId

        passert "Exactly one proposal token must be minted" $
          hasOnlyOneTokenOfCurrencySymbol # pProposalSym # txInfo.mint

        outputs <- plet $ findOutputsToAddress # ctx.txInfo # pconstant proposalValidatorAddress
        passert "Exactly one utxo should be sent to the proposal validator" $
          plength # outputs #== 1

        output <- pletFields @'["value", "datumHash"] $ phead # outputs
        passert "The proposal state token must be sent to the proposal validator" $
          psymbolValueOf # pProposalSym # output.value #== 1

        passert "The utxo paid to the proposal validator must have datum" $
          pisDJust # output.datumHash

        let proposalDatum' =
              mustFindDatum' @PProposalDatum
                # output.datumHash
                # ctx.txInfo

        proposalParams <-
          pletFields
            @'["id", "status", "cosigners", "thresholds", "votes"]
            proposalDatum'

        passert "Invalid proposal id in proposal parameters" $
          proposalParams.id #== oldParams.nextProposalId

        passert "Invalid thresholds in proposal parameters" $
          proposalParams.thresholds #== oldParams.proposalThresholds

        -- passert "Initial proposal votes should be empty" $
        --   pnull #$ pto $ pto $ pfromData proposalParams.votes

        -- passert "Initial proposal status should be Draft" $ P.do
        --   s <- pmatch $ proposalParams.status
        --   case s of
        --     PDraft _ -> pconstant True
        --     _ -> pconstant False

        passert "Proposal datum must be valid" $
          proposalDatumValid # proposalDatum'

        -- TODO: proposal impl not done yet
        ptraceError "Not implemented yet"
      PMintGATs _ -> P.do
        passert "Datum should not be changed" $
          -- FIXME: There should be a better way to do this
          (pforgetData $ pdata newDatum') #== datum'

        -- TODO: any need to check the proposal datum here?

        inputsWithProposalStateToken <-
          plet $
            pfilter
              # ( plam $ \(((pfield @"value" #) . (pfield @"resolved" #)) -> value) ->
                    0 #< psymbolValueOf # pProposalSym # value
                )
              #$ pfromData txInfo.inputs

        passert "One proposal at a time" $
          plength # inputsWithProposalStateToken #== 1

        proposalInputTxOut <-
          pletFields @'["address", "value", "datumHash"] $
            pfield @"resolved" #$ phead # inputsWithProposalStateToken

        proposalDatum' <- plet $ mustFindDatum' @PProposalDatum # proposalInputTxOut.datumHash # txInfo'

        passert "Proposal datum must be valid" $
          proposalDatumValid # proposalDatum'

        proposalDatum <- pletFields @'["id", "effects", "status", "cosigners", "thresholds", "votes"] proposalDatum'

        PProposalVotes votes' <- pmatch $ pfromData proposalDatum.votes
        votes <- plet votes'

        let yesVotes = plookup' # pyesResultTag # votes
            noVotes = plookup' # pnoResultTag # votes
            -- TODO: check thresholds here
            finalResultTag = pif (yesVotes #< noVotes) pnoResultTag pyesResultTag

        effects <- plet $ plookup' # finalResultTag #$ proposalDatum.effects

        gatCount <- plet $ plength #$ pto $ pto effects

        passert "Required amount of GATs should be minted" $
          psymbolValueOf # pProposalSym # txInfo.mint #== gatCount

        passert "No token should be minted other than GAT" $
          containsSingleCurrencySymbol # txInfo.mint

        outputsWithGAT <-
          plet $
            pfilter
              # ( plam $ \((pfield @"value" #) -> value) ->
                    0 #< psymbolValueOf # pGATSym # value
                )
              #$ pfromData txInfo.outputs
        passert "Minted GAT amount should equal to amount of output GAT" $
          plength # outputsWithGAT #== gatCount

        popaque $
          pfoldr
            # ( plam $ \(pfromData -> output') _ -> P.do
                  output <- pletFields @'["address", "datumHash"] $ output'

                  let scriptHash =
                        mustBePJust # "GAT receiver is not a script"
                          #$ scriptHashFromAddress # output.address
                      datumHash =
                        mustBePDJust # "Output to effect should have datum"
                          #$ output.datumHash
 
                      expectedDatumHash =
                        mustBePJust # "Receiver is not in effect list"
                          #$ plookup # scriptHash # effects

                  passert "GAT must be tagged by the effect hash" $ authorityTokensValidIn # pGATSym # output'
                  passert "Unexpected datum" $ datumHash #== expectedDatumHash
                  (pconstant ())
              )
            # (pconstant ())
            # outputsWithGAT

      -- TODO: check proposal votes and timing
      -- TODO: waiting for impl of proposal
      PMutateGovernor _ -> P.do
        passert "No token should be burnt other than GAT" $
          containsSingleCurrencySymbol # txInfo.mint

        popaque $ singleAuthorityTokenBurned pGATSym ctx.txInfo txInfo.mint
  where
    stateTokenAssetClass :: AssetClass
    stateTokenAssetClass = governorStateTokenAssetClass params

    proposalParams :: Proposal
    proposalParams =
      Proposal
        { governorSTAssetClass = stateTokenAssetClass
        }

    proposalSymbol :: CurrencySymbol
    proposalSymbol = mintingPolicySymbol policy
      where
        policy :: MintingPolicy
        policy = mkMintingPolicy $ proposalPolicy proposalParams

    pProposalSym :: Term s PCurrencySymbol
    pProposalSym = phoistAcyclic $ pconstant proposalSymbol

    proposalValidatorAddress :: Address
    proposalValidatorAddress = Address (ScriptCredential hash) Nothing
      where
        hash :: ValidatorHash
        hash = validatorHash validator

        validator :: Validator
        validator = mkValidator $ proposalValidator proposalParams

    stateTokenValueOf :: Term s (PValue :--> PInteger)
    stateTokenValueOf = passetClassValueOf' stateTokenAssetClass

    pGATSym :: Term s PCurrencySymbol
    pGATSym = phoistAcyclic $ pconstant $ authorityTokenSymbolFromGovernor params

    pyesResultTag :: Term s PResultTag
    pyesResultTag = phoistAcyclic $ pcon $ PResultTag $ pconstant 1

    pnoResultTag :: Term s PResultTag
    pnoResultTag = phoistAcyclic $ pcon $ PResultTag $ pconstant 0

--------------------------------------------------------------------------------

governorStateTokenAssetClass :: Governor -> AssetClass
governorStateTokenAssetClass gov = AssetClass (symbol, governorStateTokenName)
  where
    policy :: MintingPolicy
    policy = mkMintingPolicy $ governorPolicy gov

    symbol :: CurrencySymbol
    symbol = mintingPolicySymbol policy

authorityTokenSymbolFromGovernor :: Governor -> CurrencySymbol
authorityTokenSymbolFromGovernor gov = mintingPolicySymbol policy
  where
    params = AuthorityToken $ governorStateTokenAssetClass gov
    policy = mkMintingPolicy $ authorityTokenPolicy params