{-# LANGUAGE RecordWildCards #-}

-- | Functions operating on UTXO (in 'UtxoM' monad).

module Pos.Chain.Txp.Toil.Utxo.Functions
       ( VTxContext (..)
       , VerifyTxUtxoRes (..)
       , verifyTxUtxo
       , applyTxToUtxo
       , rollbackTxUtxo
       ) where

import           Universum

import           Control.Monad.Except (throwError)
import qualified Data.List.NonEmpty as NE
import           Data.Set (Set)
import qualified Data.Set as Set
import           Formatting (int, sformat, (%))
import           Serokell.Util (allDistinct, enumerate)

import           Pos.Chain.Script (Script (..))
import           Pos.Chain.Txp.Toil.Failure (ToilVerFailure (..),
                     TxOutVerFailure (..), WitnessVerFailure (..))
import           Pos.Chain.Txp.Toil.Monad (UtxoM, utxoDel, utxoGet, utxoPut)
import           Pos.Chain.Txp.Toil.Types (TxFee (..))
import           Pos.Chain.Txp.Tx (Tx (..), TxAttributes, TxIn (..), TxOut (..),
                     isTxInUnknown)
import           Pos.Chain.Txp.TxAux (TxAux (..))
import           Pos.Chain.Txp.TxOutAux (TxOutAux (..))
import           Pos.Chain.Txp.TxWitness (TxInWitness (..), TxSigData (..),
                     TxWitness)
import           Pos.Chain.Txp.Undo (TxUndo)
import           Pos.Core (AddrType (..), Address (..), integerToCoin,
                     isRedeemAddress, isUnknownAddressType, sumCoins)
import           Pos.Core.Attributes (Attributes (..), areAttributesKnown)
import           Pos.Core.Common (AddrAttributes (..), checkPubKeyAddress,
                     checkRedeemAddress)
import           Pos.Core.NetworkMagic (NetworkMagic)
import           Pos.Crypto (SignTag (SignRedeemTx, SignTx), WithHash (..),
                     checkSig, hash, redeemCheckSig)
import           Pos.Crypto.Configuration (ProtocolMagic)
import           Pos.Util (liftEither)

----------------------------------------------------------------------------
-- Verification
----------------------------------------------------------------------------

-- CSL-366 Add context-dependent variables to scripts
-- Postponed for now, should be done in near future.
-- Maybe these datatypes should be moved to Types.
-- | Global context data needed for tx verification. VT stands for
-- "Verify Tx". To be populated in further versions.
data VTxContext = VTxContext
    { -- | Verify that script versions in tx are known, addresses' and
      -- witnesses' types are known, attributes are known too.
      vtcVerifyAllIsKnown :: !Bool
--    , vtcSlotId   :: !SlotId         -- ^ Slot id of block transaction is checked in
--    , vtcLeaderId :: !StakeholderId  -- ^ Leader id of block transaction is checked in
    , vtcNetworkMagic     :: !NetworkMagic
    }

-- | Result of successful 'Tx' verification based on Utxo.
data VerifyTxUtxoRes = VerifyTxUtxoRes
    { vturUndo :: !TxUndo
    -- ^ 'TxUndo' for the verified transaction.
    , vturFee  :: !(Maybe TxFee)
    -- ^ Fee of the verified transaction. Can be 'Nothing' if there
    -- are inputs of unknown types.
    } deriving (Show)

-- | CHECK: Verify Tx correctness using 'UtxoLookup'.
-- Specifically there are the following checks:
--
-- * every input is a known unspent output;
-- * sum of inputs >= sum of outputs;
-- * every input has a proper witness verifying that input;
-- * script witnesses have matching script versions;
-- * if 'vtcVerifyAllIsKnown' is 'True', addresses' versions are verified
--   to be known, as well as witnesses, attributes, script versions.
--
-- Note that 'verifyTxUtxo' doesn't attempt to verify scripts with
-- versions higher than maximum script version we can handle. That's
-- because we want blocks with such transactions to be accepted (to
-- avoid hard forks). However, we won't include such transactions into
-- blocks when we're creating a block (because transactions for
-- inclusion into blocks are verified with 'vtcVerifyAllIsKnown'
-- set to 'True', so unknown script versions are rejected).
verifyTxUtxo
    :: ProtocolMagic
    -> VTxContext
    -> Set Address
    -> TxAux
    -> ExceptT ToilVerFailure UtxoM VerifyTxUtxoRes
verifyTxUtxo protocolMagic ctx@VTxContext {..} lockedAssets ta@(TxAux UnsafeTx {..} witnesses) = do
    let unknownTxInMB = find (isTxInUnknown . snd) $ zip [0..] (toList _txInputs)
    case (vtcVerifyAllIsKnown, unknownTxInMB) of
        (True, Just (inpId, txIn)) -> throwError $
            ToilUnknownInput inpId txIn
        (False, Just _) -> do
            -- Case when at least one input isn't known
            minimalReasonableChecks
            resolvedInputs :: NonEmpty (Maybe (TxIn, TxOutAux)) <-
                mapM
                    (lift . fmap rightToMaybe . runExceptT . resolveInput)
                    _txInputs
            pure VerifyTxUtxoRes
                 { vturUndo = map (fmap snd) resolvedInputs
                 , vturFee = Nothing
                 }
        (_, Nothing) -> do
            -- Case when all inputs are known
            minimalReasonableChecks
            resolvedInputs <- filterAssetLocked =<< mapM resolveInput _txInputs
            liftEither $ do
                txFee <- verifySums resolvedInputs _txOutputs
                verifyKnownInputs protocolMagic ctx resolvedInputs ta
                when vtcVerifyAllIsKnown $ verifyAttributesAreKnown _txAttributes
                pure VerifyTxUtxoRes
                    { vturUndo = map (Just . snd) resolvedInputs
                    , vturFee = Just txFee
                    }
  where
    minimalReasonableChecks :: ExceptT ToilVerFailure UtxoM ()
    minimalReasonableChecks = liftEither $ do
        verifyConsistency _txInputs witnesses
        verifyOutputs ctx ta

    -- Until multisig addresses are available (which is supposed to be before decentralisation)
    -- all Ada are secured by single cryptographic signatures. In addition, before
    -- decentralisation, all blocks are being mined/minted by IOHK, Emurgo and the Cardano
    -- Foundation. These machines are run by the IOHK devops team and all run the same version
    -- of the software. Before decentralisation, the lockedAssets can provide extra protection for
    -- the Ada held by these entities. It is intended that this lockedAssets functionality will be
    -- removed after multisig addresses are available but before decentralisation.
    --
    -- After decentralisation, anyone can modify the code to add or remove similar functionality,
    -- but the decentralised nature of the network should make any such action irrelevant.
    filterAssetLocked
        :: NonEmpty (TxIn, TxOutAux)
        -> ExceptT ToilVerFailure UtxoM (NonEmpty (TxIn, TxOutAux))
    filterAssetLocked xs =
        case NE.filter notAssetLockedSrcAddr xs of
            []     -> throwError ToilEmptyAfterFilter
            (y:ys) -> pure (y :| ys)

    -- Return `True` iff none of the source addresses are in the lockedAssets set.
    notAssetLockedSrcAddr :: (txin, TxOutAux) -> Bool
    notAssetLockedSrcAddr (_, tao) =
        txOutAddress (toaOut tao) `Set.notMember` lockedAssets


-- | For a given TxIn, look up the TxOutAux that it is spending.
resolveInput :: TxIn -> ExceptT ToilVerFailure UtxoM (TxIn, TxOutAux)
resolveInput txIn =
    (txIn, ) <$> (note (ToilNotUnspent txIn) =<< lift (utxoGet txIn))

verifySums ::
       NonEmpty (TxIn, TxOutAux)
    -> NonEmpty TxOut
    -> Either ToilVerFailure TxFee
verifySums resolvedInputs outputs =
  case mTxFee of
      Nothing -> throwError $
          ToilOutGreaterThanIn inpSum outSum
      Just txFee ->
          return txFee
  where
    -- It will be 'Nothing' if value exceeds 'maxBound @Coin' (can't
    -- happen because 'inpSum' doesn't exceed it and 'outSum' is not
    -- negative) or if 'outSum > inpSum' (which can happen and should
    -- be rejected).
    mTxFee = TxFee <$> rightToMaybe (integerToCoin (inpSum - outSum))
    outSum = sumCoins $ map txOutValue outputs
    inpSum = sumCoins $ map (txOutValue . toaOut . snd) resolvedInputs

verifyConsistency :: NonEmpty TxIn -> TxWitness -> Either ToilVerFailure ()
verifyConsistency inputs witnesses
    | length inputs == length witnesses = pass
    | otherwise = throwError $ ToilInconsistentTxAux errMsg
  where
    errFmt = ("length of inputs != length of witnesses "%"("%int%" != "%int%")")
    errMsg = sformat errFmt (length inputs) (length witnesses)

verifyOutputs :: VTxContext -> TxAux -> Either ToilVerFailure ()
verifyOutputs VTxContext {..} (TxAux UnsafeTx {..} _) =
    mapM_ verifyOutput . enumerate $ toList _txOutputs
  where
    verifyOutput :: (Word32, TxOut) -> Either ToilVerFailure ()
    verifyOutput (i, (TxOut {txOutAddress = addr@Address {..}, ..})) = do
        when (vtcVerifyAllIsKnown && not (areAttributesKnown addrAttributes)) $
            throwError $ ToilInvalidOutput i (TxOutUnknownAttributes addr)
        when (vtcVerifyAllIsKnown && isUnknownAddressType addr) $
            throwError $ ToilInvalidOutput i (TxOutUnknownAddressType addr)
        when (isRedeemAddress addr) $
            throwError $ ToilInvalidOutput i (TxOutRedeemAddressProhibited addr)
        unless (addressHasValidMagic (attrData addrAttributes)) $
            throwError $ ToilInvalidOutput i (TxOutAddressBadNetworkMagic addr)

    addressHasValidMagic :: AddrAttributes -> Bool
    addressHasValidMagic addrAttrs = vtcNetworkMagic == (aaNetworkMagic addrAttrs)

-- Verify inputs of a transaction after they have been resolved
-- (implies that they are known).
verifyKnownInputs ::
       ProtocolMagic
    -> VTxContext
    -> NonEmpty (TxIn, TxOutAux)
    -> TxAux
    -> Either ToilVerFailure ()
verifyKnownInputs protocolMagic VTxContext {..} resolvedInputs TxAux {..} = do
    unless allInputsDifferent $ throwError ToilRepeatedInput
    mapM_ (uncurry3 checkInput) $
        zip3 [0 ..] (toList resolvedInputs) (toList witnesses)
  where
    uncurry3 f (a, b, c) = f a b c
    witnesses = taWitness
    txHash = hash taTx
    txSigData = TxSigData txHash

    allInputsDifferent :: Bool
    allInputsDifferent = allDistinct (toList (map fst resolvedInputs))

    checkInput
        :: Word32           -- ^ Input index
        -> (TxIn, TxOutAux) -- ^ Input and corresponding output data
        -> TxInWitness
        -> Either ToilVerFailure ()
    checkInput i (txIn, toa@(TxOutAux txOut@TxOut{..})) witness = do
        unless (checkSpendingData txOutAddress witness) $
            throwError $ ToilWitnessDoesntMatch i txIn txOut witness
        whenLeft (checkWitness toa witness) $ \err ->
            throwError $ ToilInvalidWitness i witness err

    checkSpendingData addr wit = case wit of
        PkWitness twKey _            -> checkPubKeyAddress twKey addr
        -- The existing blockchain should not have any output addresses of this
        -- witness type, so checking should just fail.
        ScriptWitness _ _            -> False
        RedeemWitness twRedeemKey _  -> checkRedeemAddress twRedeemKey addr
        UnknownWitnessType witTag _  -> case addrType addr of
            ATUnknown addrTag -> addrTag == witTag
            _                 -> False

    -- the first argument here includes local context, can be used for scripts
    checkWitness :: TxOutAux -> TxInWitness -> Either WitnessVerFailure ()
    checkWitness _txOutAux witness = case witness of
        PkWitness twKey twSig ->
            unless (checkSig protocolMagic SignTx twKey txSigData twSig) $
                throwError WitnessWrongSignature
        RedeemWitness twRedeemKey twRedeemSig ->
            unless (redeemCheckSig protocolMagic SignRedeemTx twRedeemKey txSigData twRedeemSig) $
                throwError WitnessWrongSignature
        ScriptWitness twValidator twRedeemer -> do
            -- The existing blockchain should not have any witnesses of this
            -- type, so checking should just fail using the following.
            Left $ WitnessScriptVerMismatch (scrVersion twValidator) (scrVersion twRedeemer)
        UnknownWitnessType t _ ->
            when vtcVerifyAllIsKnown $
                throwError $ WitnessUnknownType t

verifyAttributesAreKnown
    :: TxAttributes -> Either ToilVerFailure ()
verifyAttributesAreKnown attrs =
    unless (areAttributesKnown attrs) $
    throwError $ ToilUnknownAttributes (attrRemain attrs)

-- | Remove unspent outputs used in given transaction, add new unspent
-- outputs.
applyTxToUtxo :: WithHash Tx -> UtxoM ()
applyTxToUtxo (WithHash UnsafeTx {..} txid) = do
    mapM_ utxoDel $ filter (not . isTxInUnknown) (toList _txInputs)
    mapM_ applyOutput . zip [0 ..] . toList . map TxOutAux $ _txOutputs
  where
    applyOutput (idx, toa) = utxoPut (TxInUtxo txid idx) toa

-- | Rollback application of given transaction to Utxo using Undo
-- data.  This function assumes that transaction has been really
-- applied and doesn't check anything.
rollbackTxUtxo :: (TxAux, TxUndo) -> UtxoM ()
rollbackTxUtxo (txAux, undo) = do
    let tx@UnsafeTx {..} = taTx txAux
    let txid = hash tx
    mapM_ utxoDel $ take (length _txOutputs) $ map (TxInUtxo txid) [0..]
    mapM_ (uncurry utxoPut) $ mapMaybe knownInputAndUndo $ toList $ NE.zip _txInputs undo
  where
    knownInputAndUndo (_,         Nothing) = Nothing
    knownInputAndUndo (TxInUnknown _ _, _) = Nothing
    knownInputAndUndo (inp, Just u)        = Just (inp, u)
