content: {- |
  Module     : Agora.Stake.Redeemers
  Maintainer : connor@mlabs.city
  Description: Default implementation of stake redeemer handlers
  
  Default implementation of stake redeemer handlers.
  -}
  module Agora.Stake.Redeemers (
    ppermitVote,
    pretractVote,
    pdelegateTo,
    pclearDelegate,
    pdestroy,
    pdepositWithdraw,
  ) where
  
  import Agora.Proposal (
    PProposalId,
    PProposalRedeemer (PCosign, PUnlockStake, PVote),
    ProposalStatus (Finished),
   )
  import Agora.Proposal.Time (PProposalTime)
  import Agora.Stake (
    PProposalAction (PCosigned, PCreated, PVoted),
    PProposalContext (
      PNewProposal,
      PNoProposal,
      PSpendProposal
    ),
    PProposalLock (PProposalLock),
    PSigContext (owner, signedBy),
    PSignedBy (
      PSignedByDelegate,
      PSignedByOwner,
      PUnknownSig
    ),
    PStakeDatum (PStakeDatum),
    PStakeRedeemerContext (
      PDepositWithdrawDelta,
      PNoMetadata,
      PSetDelegateTo
    ),
    PStakeRedeemerHandler,
    PStakeRedeemerHandlerContext (
      proposalContext,
      redeemerContext,
      sigContext,
      stakeInputDatums,
      stakeOutputDatums
    ),
    pstakeLocked,
   )
  import Plutarch.Api.V1.Address (PCredential)
  import Plutarch.Api.V2 (PMaybeData, PPOSIXTime)
  import Plutarch.Extra.Bool (passert)
  import Plutarch.Extra.Field (pletAll, pletAllC)
  import Plutarch.Extra.Maybe (pdjust, pdnothing, pmaybeData)
  import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
  import Plutarch.Extra.Time (PFullyBoundedTimeRange (PFullyBoundedTimeRange))
  import "liqwid-plutarch-extra" Plutarch.Extra.List (
    pisSingleton,
    ptryDeleteFirstBy,
    ptryFromSingleton,
   )
  import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
  
  -- | A wrapper which ensures that no proposal is presented in the transaction.
  pwithoutProposal ::
    forall (s :: S).
    Term
      s
      (PStakeRedeemerHandler :--> PStakeRedeemerHandler)
  pwithoutProposal = phoistAcyclic $
    plam $ \f ctx -> pmatch ctx $ \ctxF ->
      pif
        ( pmatch ctxF.proposalContext $ \case
            PNoProposal -> pconstant True
            _ -> pconstant False
        )
        (f # ctx)
        (ptraceError "No proposal is allowed")
  
  {- | Validate stake outputs given a function that converts an input stake datum
        to an ouput stake datum. / O(n^2) /.
  -}
  pbatchUpdateInputs ::
    forall (s :: S).
    Term
      s
      ( (PStakeDatum :--> PStakeDatum :--> PBool)
          :--> PStakeRedeemerHandlerContext
          :--> PBool
      )
  pbatchUpdateInputs = phoistAcyclic $
    plam $ \f -> flip pmatch $ \ctxF ->
      pnull
        #$ pfoldr
        # plam (\x -> ptryDeleteFirstBy # (f # x))
        # ctxF.stakeOutputDatums
        # ctxF.stakeInputDatums
  
  -- | Extract the 'PSigContext.signedBy' field from 'PStakeRedeemerHandlerContext'.
  pgetSignedBy ::
    forall (s :: S).
    Term
      s
      (PStakeRedeemerHandlerContext :--> PSignedBy)
  pgetSignedBy = phoistAcyclic $
    plam $ \ctx -> unTermCont $ do
      ctxF <- pmatchC ctx
      sctxF <- pmatchC ctxF.sigContext
      pure sctxF.signedBy
  
  -- | Return true if the tx is authorized by either the owner or the delegatee.
  pisSignedBy ::
    forall (s :: S).
    Term
      s
      (PBool :--> PStakeRedeemerHandlerContext :--> PBool)
  pisSignedBy = phoistAcyclic $
    plam $ \byDelegate ctx ->
      pmatch (pgetSignedBy # ctx) $ \case
        PSignedByOwner -> pconstant True
        PSignedByDelegate -> byDelegate
        PUnknownSig -> pconstant False
  
  -- | Return true if only the @lockedBy@ field of the stake datum is updated.
  ponlyLocksUpdated ::
    forall (s :: S).
    Term
      s
      ( ( PBuiltinList (PAsData PProposalLock)
            :--> PBuiltinList (PAsData PProposalLock)
        )
          :--> PStakeRedeemerHandlerContext
          :--> PBool
      )
  ponlyLocksUpdated = phoistAcyclic $
    plam $ \f ->
      pbatchUpdateInputs #$ plam $ \i o ->
        pletAll i $ \iF ->
          let newLocks = f # pfromData iF.lockedBy
  
              expected =
                mkRecordConstr
                  PStakeDatum
                  ( #stakedAmount
                      .= iF.stakedAmount
                      .& #owner
                      .= iF.owner
                      .& #delegatedTo
                      .= iF.delegatedTo
                      .& #lockedBy
                      .= pdata newLocks
                  )
           in expected #== o
  
  -- | Validation logic shared between 'ppermitVote' and 'retractVote'.
  pvoteHelper ::
    forall (s :: S).
    Term
      s
      ( ( PStakeRedeemerHandlerContext
            :--> PBuiltinList (PAsData PProposalLock)
            :--> PBuiltinList (PAsData PProposalLock)
        )
          :--> PStakeRedeemerHandler
      )
  pvoteHelper = phoistAcyclic $
    plam $ \valProposalCtx ctx ->
      -- This puts trust into the Proposal. The Proposal must necessarily check
      -- that this is not abused.
      passert
        "Correct outputs"
        (ponlyLocksUpdated # (valProposalCtx # ctx) # ctx)
        (pconstant ())
  
  -- | Add new lock the the existing list of locked.
  paddNewLock ::
    forall (s :: S).
    Term
      s
      ( PProposalLock
          :--> PBuiltinList (PAsData PProposalLock)
          :--> PBuiltinList (PAsData PProposalLock)
      )
  paddNewLock = phoistAcyclic $
    plam $
      -- Prepend the lock.
      \newLock -> pcons # pdata newLock
  
  {- | Default implementation of 'Agora.Stake.PermitVote'.
  
       @since 1.0.0
  -}
  ppermitVote :: forall (s :: S). Term s PStakeRedeemerHandler
  ppermitVote = pvoteHelper #$ phoistAcyclic $
    plam $ \ctx -> unTermCont $ do
      ctxF <- pmatchC ctx
  
      withOnlyOneStakeInput <- pletC $
        plam $ \lock -> unTermCont $ do
          pguardC "Only one stake input allowed" $
            pisSingleton # ctxF.stakeInputDatums
  
          pguardC "Owner signs this transaction" $
            pisSignedBy # pconstant False # ctx
  
          pure lock
  
      pure $
        paddNewLock #$ pmatch ctxF.proposalContext $ \case
          PSpendProposal proposal redeemer currentTime -> unTermCont $ do
            mkLock <- pletC $
              plam $ \action ->
                mkRecordConstr
                  PProposalLock
                  ( #proposalId
                      .= pfield @"proposalId"
                      # proposal
                      .& #action
                      .= pdata action
                  )
  
            pure $
              pmatch redeemer $ \case
                PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) ->
                  unTermCont $ do
                    pguardC "Owner or delegatee signs the transaction" $
                      pisSignedBy # pconstant True # ctx
  
                    PFullyBoundedTimeRange _ upperBound <- pmatchC currentTime
  
                    let action =
                          mkRecordConstr
                            PVoted
                            ( #votedFor
                                .= pdata voteFor
                                .& #createdAt
                                .= pdata upperBound
                            )
  
                    pure $ mkLock # action
                PCosign _ ->
                  let action = pcon $ PCosigned pdnil
                   in withOnlyOneStakeInput #$ mkLock # action
                _ -> ptraceError "Expected Vote or Cosign"
          PNewProposal proposalId ->
            let action = pcon $ PCreated pdnil
                lock =
                  mkRecordConstr
                    PProposalLock
                    ( #proposalId
                        .= pdata proposalId
                        .& #action
                        .= pdata action
                    )
             in withOnlyOneStakeInput # lock
          _ -> ptraceError "Expected a proposal to be spent or created"
  
  data PRemoveLocksMode (s :: S) = PRemoveVoterLockOnly | PRemoveAllLocks
    deriving stock (Generic)
    deriving anyclass (PlutusType, PEq)
  
  instance DerivePlutusType PRemoveLocksMode where
    type DPTStrat _ = PlutusTypeScott
  
  {- | Remove stake locks with the proposal id given the list of existing locks.
       The first parameter controls whether to remove creator locks or not. If
       one of the locks performed voting action, the unlock cooldown will be
       checked.
  -}
  premoveLocks ::
    forall (s :: S).
    Term
      s
      ( PProposalId
          :--> PPOSIXTime
          :--> PProposalTime
          :--> PRemoveLocksMode
          :--> PBuiltinList (PAsData PProposalLock)
          :--> PBuiltinList (PAsData PProposalLock)
      )
  premoveLocks =
    phoistAcyclic $
      plam $ \proposalId unlockCooldown currentTime mode -> unTermCont $ do
        shouldRemoveAllLocks <- pletC $ mode #== pcon PRemoveAllLocks
  
        PFullyBoundedTimeRange lowerBound _ <- pmatchC currentTime
  
        let handleVoter
              ( (pfield @"createdAt" #) ->
                  createdAt
                ) =
                let notInCooldown = createdAt + unlockCooldown #<= lowerBound
                 in pif shouldRemoveAllLocks (pconstant True) $
                      -- Fail the transaction if a voter lock is in cooldown.
                      passert
                        "Voter lock shouldn't be in cooldown"
                        notInCooldown
                        (pconstant True)
  
            shouldRemoveLock =
              flip
                pletAll
                ( \lockF ->
                    foldl1
                      (#&&)
                      [ proposalId #== lockF.proposalId
                      , pmatch lockF.action $ \case
                          PVoted r -> handleVoter r
                          _ -> shouldRemoveAllLocks
                      ]
                )
                . pfromData
  
            -- Return true, given a lock that should be kept.
            handleLock = plam $ (pnot #) . shouldRemoveLock
  
        pure $ pfilter # handleLock
  
  {- | Default implementation of 'Agora.Stake.RetractVotes'.
  
       @since 1.0.0
  -}
  pretractVote :: forall (s :: S). Term s PStakeRedeemerHandler
  pretractVote = pvoteHelper #$ phoistAcyclic $
    plam $ \ctx ->
      pmatch ctx $ \ctxF ->
        pmatch ctxF.proposalContext $ \case
          PSpendProposal proposal redeemer currentTime -> pmatch redeemer $ \case
            PUnlockStake _ -> unTermCont $ do
              proposalF <-
                pletFieldsC
                  @'[ "proposalId"
                    , "status"
                    , "timingConfig"
                    ]
                  proposal
  
              let unlockCooldown =
                    pfield @"minStakeVotingTime"
                      # proposalF.timingConfig
  
                  mode = pmatch (proposalF.status #== pconstant Finished) $ \case
                    PTrue -> pcon PRemoveAllLocks
                    _ -> pcon PRemoveVoterLockOnly
  
              pguardC "Authorized by either opwner or delegatee" $
                pisSignedBy # pconstant True # ctx
  
              pure $
                premoveLocks
                  # proposalF.proposalId
                  # unlockCooldown
                  # currentTime
                  # mode
            _ -> ptraceError "Expected unlock"
          _ -> ptraceError "Expected spending proposal"
  
  -- | Validation logic shared by 'pdelegateTo' and 'pclearDelegate'.
  pdelegateHelper ::
    forall (s :: S).
    Term
      s
      ( (PStakeRedeemerContext :--> PMaybeData (PAsData PCredential))
          :--> PStakeRedeemerHandler
      )
  pdelegateHelper = phoistAcyclic $
    plam $ \f -> pwithoutProposal #$ plam $ \ctx -> unTermCont $ do
      ctxF <- pmatchC ctx
      sigCtxF <- pmatchC ctxF.sigContext
  
      pguardC "Owner signs this transaction" $
        pisSignedBy # pconstant False # ctx
  
      let newDelegate = f # ctxF.redeemerContext
  
      pguardC "Cannot delegate to the owner" $
        pmaybeData
          # pcon PTrue
          # plam (\pkh -> pnot #$ sigCtxF.owner #== pfromData pkh)
          # newDelegate
  
      pguardC "Correct outputs" $
        pbatchUpdateInputs
          # plam
            ( \i o -> pletAll i $ \iF ->
                mkRecordConstr
                  PStakeDatum
                  ( #stakedAmount
                      .= iF.stakedAmount
                      .& #owner
                      .= iF.owner
                      .& #delegatedTo
                      .= pdata newDelegate
                      .& #lockedBy
                      .= iF.lockedBy
                  )
                  #== o
            )
          # ctx
  
      pure $ pconstant ()
  
  {- | Default implementation of 'Agora.Stake.DelegateTo'.
  
       @since 1.0.0
  -}
  pdelegateTo :: forall (s :: S). Term s PStakeRedeemerHandler
  pdelegateTo = pdelegateHelper #$ phoistAcyclic $
    plam $
      flip pmatch $ \case
        PSetDelegateTo c -> pdjust # pdata c
        _ -> perror
  
  {- | Default implementation of 'Agora.Stake.ClearDelegate'.
  
       @since 1.0.0
  -}
  pclearDelegate :: forall (s :: S). Term s PStakeRedeemerHandler
  pclearDelegate = pdelegateHelper #$ phoistAcyclic $
    plam $
      flip pmatch $ \case
        PNoMetadata -> pdnothing
        _ -> perror
  
  {- | Default implementation of 'Agora.Stake.Destroy'.
  
       @since 1.0.0
  -}
  pdestroy :: forall (s :: S). Term s PStakeRedeemerHandler
  pdestroy = phoistAcyclic $
    pwithoutProposal #$ plam $ \ctx -> unTermCont $ do
      ctxF <- pmatchC ctx
  
      pguardC "Owner signs this transaction" $
        pisSignedBy # pconstant False # ctx
  
      pguardC "All stakes unlocked" $
        pnot #$ pany # pstakeLocked # ctxF.stakeInputDatums
  
      pguardC "All stakes burnt" $
        pnull # ctxF.stakeOutputDatums
  
      pure $ pconstant ()
  
  {- | Default implementation of 'Agora.Stake.DepositWithdraw'.
  
       @since 1.0.0
  -}
  pdepositWithdraw :: forall (s :: S). Term s PStakeRedeemerHandler
  pdepositWithdraw = phoistAcyclic $
    pwithoutProposal #$ plam $ \ctx -> unTermCont $ do
      ctxF <- pmatchC ctx
  
      pguardC "Owner signs this transaction" $
        pisSignedBy # pconstant False # ctx
  
      ----------------------------------------------------------------------------
  
      stakeInputDatum <-
        pletC $
          ptrace "Single stake input" $
            ptryFromSingleton # ctxF.stakeInputDatums
      stakeInputDatumF <- pletAllC stakeInputDatum
  
      let stakeOutputDatum =
            ptrace "Single stake output" $
              ptryFromSingleton # ctxF.stakeOutputDatums
  
      ----------------------------------------------------------------------------
  
      pguardC "Stake unlocked" $
        pnot #$ pstakeLocked # stakeInputDatum
  
      ----------------------------------------------------------------------------
  
      PDepositWithdrawDelta delta <- pmatchC ctxF.redeemerContext
  
      newStakedAmount <- pletC $ stakeInputDatumF.stakedAmount + delta
  
      pguardC "Non-negative staked amount" $ 0 #<= newStakedAmount
  
      let expectedDatum =
            mkRecordConstr
              PStakeDatum
              ( #stakedAmount
                  .= pdata newStakedAmount
                  .& #owner
                  .= stakeInputDatumF.owner
                  .& #delegatedTo
                  .= stakeInputDatumF.delegatedTo
                  .& #lockedBy
                  .= stakeInputDatumF.lockedBy
              )
  
      pguardC "Valid output datum" $ expectedDatum #== stakeOutputDatum
  
      pure $ pconstant ()
  