{-# LANGUAGE TypeFamilies #-}

module Pos.Chain.Ssc.Functions
       ( hasCommitment
       , hasOpening
       , hasShares
       , hasVssCertificate

       -- * SscPayload
       , verifySscPayload

       -- * VSS
       , vssThreshold
       , getStableCertsPure
       ) where

import           Universum hiding (id)

import           Control.Lens (to)
import           Control.Monad.Except (MonadError (throwError))
import qualified Data.HashMap.Strict as HM
import           Serokell.Util.Verify (isVerSuccess)

import           Pos.Chain.Block.IsHeader (IsMainHeader, headerSlotL)
import           Pos.Chain.Genesis as Genesis (Config (..),
                     configBlkSecurityParam, configVssCerts)
import           Pos.Chain.Ssc.Base (checkCertTTL, isCommitmentId, isOpeningId,
                     isSharesId, verifySignedCommitment, vssThreshold)
import           Pos.Chain.Ssc.CommitmentsMap (CommitmentsMap (..))
import           Pos.Chain.Ssc.Error (SscVerifyError (..))
import           Pos.Chain.Ssc.Payload (SscPayload (..))
import           Pos.Chain.Ssc.Toss.Base (verifyEntriesGuardM)
import           Pos.Chain.Ssc.Types (SscGlobalState (..))
import qualified Pos.Chain.Ssc.VssCertData as VCD
import           Pos.Chain.Ssc.VssCertificatesMap (VssCertificatesMap)
import           Pos.Core (EpochIndex (..), SlotId (..), StakeholderId,
                     pcBlkSecurityParam)
import           Pos.Core.Slotting (crucialSlot)
import           Pos.Util.Some (Some)

----------------------------------------------------------------------------
-- Simple predicates for SSC.Types
----------------------------------------------------------------------------

hasCommitment :: StakeholderId -> SscGlobalState -> Bool
hasCommitment id = HM.member id . getCommitmentsMap . _sgsCommitments

hasOpening :: StakeholderId -> SscGlobalState -> Bool
hasOpening id = HM.member id . _sgsOpenings

hasShares :: StakeholderId -> SscGlobalState -> Bool
hasShares id = HM.member id . _sgsShares

hasVssCertificate :: StakeholderId -> SscGlobalState -> Bool
hasVssCertificate id = VCD.member id . _sgsVssCertificates

----------------------------------------------------------------------------
-- SscPayload Part
----------------------------------------------------------------------------

-- CHECK: @verifySscPayload
-- Verify payload using header containing this payload.
--
-- For each DS datum we check:
--
--   1. Whether it's stored in the correct block (e.g. commitments have to be
--      in first 2 * blkSecurityParam blocks, etc.)
--
--   2. Whether the message itself is correct (e.g. commitment signature is
--      valid, etc.)
--
-- We also do some general sanity checks.
verifySscPayload
    :: MonadError SscVerifyError m
    => Genesis.Config -> Either EpochIndex (Some IsMainHeader) -> SscPayload -> m ()
verifySscPayload genesisConfig eoh payload = case payload of
    CommitmentsPayload comms certs -> do
        whenHeader eoh isComm
        commChecks comms
        certsChecks certs
    OpeningsPayload        _ certs -> do
        whenHeader eoh isOpen
        certsChecks certs
    SharesPayload          _ certs -> do
        whenHeader eoh isShare
        certsChecks certs
    CertificatesPayload      certs -> do
        whenHeader eoh isOther
        certsChecks certs
  where
    whenHeader (Left _) _       = pass
    whenHeader (Right header) f = f $ header ^. headerSlotL

    epochId = either identity (view $ headerSlotL . to siEpoch) eoh
    pc = configProtocolConstants genesisConfig
    k = pcBlkSecurityParam pc
    isComm  slotId = unless (isCommitmentId k slotId) $ throwError $ NotCommitmentPhase slotId
    isOpen  slotId = unless (isOpeningId k slotId) $ throwError $ NotOpeningPhase slotId
    isShare slotId = unless (isSharesId k slotId) $ throwError $ NotSharesPhase slotId
    isOther slotId = unless (all not $
                      map ($ slotId) [isCommitmentId k, isOpeningId k, isSharesId k]) $
                      throwError $ NotIntermediatePhase slotId

    -- We *forbid* blocks from having commitments/openings/shares in blocks
    -- with wrong slotId (instead of merely discarding such commitments/etc)
    -- because it's the miner's responsibility not to include them into the
    -- block if they're late.
    --
    -- CHECK: For commitments specifically, we also
    --
    --   * check there are only commitments in the block
    --   * use verifySignedCommitment, which checks commitments themselves,
    --     e.g. checks their signatures (which includes checking that the
    --     commitment has been generated for this particular epoch)
    --
    -- #verifySignedCommitment
    commChecks commitments = do
        let checkComm = isVerSuccess . verifySignedCommitment
                (configProtocolMagic genesisConfig)
                epochId
        verifyEntriesGuardM fst snd CommitmentInvalid
                            (pure . checkComm)
                            (HM.toList . getCommitmentsMap $ commitments)

    -- CHECK: Vss certificates checker
    --
    --   * VSS certificates are signed properly
    --   * VSS certificates have valid TTLs
    --
    -- #checkCert
    certsChecks certs =
        verifyEntriesGuardM identity identity CertificateInvalidTTL
                            (pure . checkCertTTL pc epochId)
                            (toList certs)

----------------------------------------------------------------------------
-- Modern
----------------------------------------------------------------------------

getStableCertsPure
    :: Genesis.Config
    -> EpochIndex
    -> VCD.VssCertData
    -> VssCertificatesMap
getStableCertsPure genesisConfig epoch certs
    | epoch == 0 = configVssCerts genesisConfig
    | otherwise = VCD.certs $ VCD.setLastKnownSlot
        (crucialSlot (configBlkSecurityParam genesisConfig) epoch)
        certs
