{- | Per-purpose evaluation and declaration arithmetic. Failed evaluations
carry errors, never fabricated measurements.
-}
module Conformance.PurposeUnits
    ( PurposeUnits
    , PurposeMeasurements
    , doublePurposeUnits
    , fallbackBelowMaximum
    , maximumPurposeUnits
    , missingPurposeBudgets
    , overBudgetPurposes
    , allocatePurposeUnits
    , protocolUnitsCeiling
    , budgetRefusalPurposes
    ) where

import Conformance.Refusal (refusalScriptHashes)
import Data.Bifunctor (bimap)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as T

type PurposeUnits = Map Text (Integer, Integer)

type PurposeMeasurements = Map Text (Either Text (Integer, Integer))

{- | Double successful evaluations. Failed evaluations retain the existing
live harness fallback (1% memory / 5% CPU of the transaction maximum),
explicitly as a probe rather than a fabricated measurement. The complete
declaration must fit both transaction and block limits.
-}
allocatePurposeUnits
    :: (Integer, Integer)
    -> (Integer, Integer)
    -> PurposeMeasurements
    -> Either Text PurposeUnits
allocatePurposeUnits :: (Integer, Integer)
-> (Integer, Integer)
-> PurposeMeasurements
-> Either Text PurposeUnits
allocatePurposeUnits transactionLimit :: (Integer, Integer)
transactionLimit@(Integer
txMem, Integer
txCpu) (Integer, Integer)
blockLimit PurposeMeasurements
measured
    | PurposeMeasurements -> Bool
forall k a. Map k a -> Bool
Map.null PurposeMeasurements
measured = Text -> Either Text PurposeUnits
forall a b. a -> Either a b
Left Text
"node evaluation returned no purposes"
    | Integer
usedMem Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
maxMem Bool -> Bool -> Bool
|| Integer
usedCpu Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
maxCpu =
        Text -> Either Text PurposeUnits
forall a b. a -> Either a b
Left
            ( Text
"harness refusal: per-purpose declarations exceed transaction/block execution-unit ceiling (mem="
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Integer -> String
forall a. Show a => a -> String
show Integer
maxMem)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", cpu="
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Integer -> String
forall a. Show a => a -> String
show Integer
maxCpu)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
            )
    | Bool
otherwise = PurposeUnits -> Either Text PurposeUnits
forall a b. b -> Either a b
Right PurposeUnits
declarations
  where
    (Integer
maxMem, Integer
maxCpu) = (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer)
protocolUnitsCeiling (Integer, Integer)
transactionLimit (Integer, Integer)
blockLimit
    doubled :: PurposeUnits
doubled =
        PurposeUnits -> PurposeUnits
doublePurposeUnits
            ((Either Text (Integer, Integer) -> Maybe (Integer, Integer))
-> PurposeMeasurements -> PurposeUnits
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe ((Text -> Maybe (Integer, Integer))
-> ((Integer, Integer) -> Maybe (Integer, Integer))
-> Either Text (Integer, Integer)
-> Maybe (Integer, Integer)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Integer, Integer) -> Text -> Maybe (Integer, Integer)
forall a b. a -> b -> a
const Maybe (Integer, Integer)
forall a. Maybe a
Nothing) (Integer, Integer) -> Maybe (Integer, Integer)
forall a. a -> Maybe a
Just) PurposeMeasurements
measured)
    failures :: Map Text ()
failures = (Either Text (Integer, Integer) -> Maybe ())
-> PurposeMeasurements -> Map Text ()
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe ((Text -> Maybe ())
-> ((Integer, Integer) -> Maybe ())
-> Either Text (Integer, Integer)
-> Maybe ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe () -> Text -> Maybe ()
forall a b. a -> b -> a
const (() -> Maybe ()
forall a. a -> Maybe a
Just ())) (Maybe () -> (Integer, Integer) -> Maybe ()
forall a b. a -> b -> a
const Maybe ()
forall a. Maybe a
Nothing)) PurposeMeasurements
measured
    declarations :: PurposeUnits
declarations = PurposeUnits -> PurposeUnits -> PurposeUnits
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union PurposeUnits
doubled PurposeUnits
probes
    usedMem :: Integer
usedMem = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Integer, Integer) -> Integer)
-> [(Integer, Integer)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, Integer) -> Integer
forall a b. (a, b) -> a
fst (PurposeUnits -> [(Integer, Integer)]
forall k a. Map k a -> [a]
Map.elems PurposeUnits
declarations))
    usedCpu :: Integer
usedCpu = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Integer, Integer) -> Integer)
-> [(Integer, Integer)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, Integer) -> Integer
forall a b. (a, b) -> b
snd (PurposeUnits -> [(Integer, Integer)]
forall k a. Map k a -> [a]
Map.elems PurposeUnits
declarations))
    probes :: PurposeUnits
probes = (() -> (Integer, Integer)) -> Map Text () -> PurposeUnits
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Integer, Integer) -> () -> (Integer, Integer)
forall a b. a -> b -> a
const (Integer
txMem Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
100, Integer
txCpu Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
20)) Map Text ()
failures

-- | A submitted transaction must fit both per-transaction and per-block limits.
protocolUnitsCeiling
    :: (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer)
protocolUnitsCeiling :: (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer)
protocolUnitsCeiling (Integer
txMem, Integer
txCpu) (Integer
blockMem, Integer
blockCpu) =
    (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min Integer
txMem Integer
blockMem, Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min Integer
txCpu Integer
blockCpu)

{- | Attribute only node-reported budget failures to their script purposes.
Each failure section must itself contain both the budget error and hash;
a different script's failure in the same report cannot supply either.
-}
budgetRefusalPurposes :: Map Text Text -> Text -> [Text]
budgetRefusalPurposes :: Map Text Text -> Text -> [Text]
budgetRefusalPurposes Map Text Text
hashes Text
reason =
    [ Text
purpose
    | (Text
purpose, Text
scriptHash) <- Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text Text
hashes
    , Text
scriptHash Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
budgetHashes
    ]
  where
    budgetHashes :: [Text]
budgetHashes =
        [ String -> Text
T.pack String
scriptHash
        | Text
failure <- Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"The PlutusV3 script failed:" Text
reason)
        , Text
"overspending the budget" Text -> Text -> Bool
`T.isInfixOf` Text
failure
        , String
scriptHash <- String -> [String]
refusalScriptHashes (Text -> String
T.unpack Text
failure)
        ]

-- | The componentwise maximum across the script-purpose evaluation map.
maximumPurposeUnits :: PurposeUnits -> Maybe (Integer, Integer)
maximumPurposeUnits :: PurposeUnits -> Maybe (Integer, Integer)
maximumPurposeUnits PurposeUnits
purposes
    | PurposeUnits -> Bool
forall k a. Map k a -> Bool
Map.null PurposeUnits
purposes = Maybe (Integer, Integer)
forall a. Maybe a
Nothing
    | Bool
otherwise =
        (Integer, Integer) -> Maybe (Integer, Integer)
forall a. a -> Maybe a
Just
            ( [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Integer
mem | (Integer
mem, Integer
_) <- PurposeUnits -> [(Integer, Integer)]
forall k a. Map k a -> [a]
Map.elems PurposeUnits
purposes]
            , [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Integer
cpu | (Integer
_, Integer
cpu) <- PurposeUnits -> [(Integer, Integer)]
forall k a. Map k a -> [a]
Map.elems PurposeUnits
purposes]
            )

-- | A fixture budget one unit below each component of the measured maximum.
fallbackBelowMaximum :: PurposeUnits -> Maybe (Integer, Integer)
fallbackBelowMaximum :: PurposeUnits -> Maybe (Integer, Integer)
fallbackBelowMaximum PurposeUnits
purposes = do
    (mem, cpu) <- PurposeUnits -> Maybe (Integer, Integer)
maximumPurposeUnits PurposeUnits
purposes
    if mem > 0 && cpu > 0
        then Just (mem - 1, cpu - 1)
        else Nothing

-- | Preserve each purpose's own measured pair when applying the 2x headroom.
doublePurposeUnits :: PurposeUnits -> PurposeUnits
doublePurposeUnits :: PurposeUnits -> PurposeUnits
doublePurposeUnits = ((Integer, Integer) -> (Integer, Integer))
-> PurposeUnits -> PurposeUnits
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Integer -> Integer)
-> (Integer -> Integer) -> (Integer, Integer) -> (Integer, Integer)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*) (Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*))

missingPurposeBudgets :: PurposeUnits -> PurposeUnits -> [Text]
missingPurposeBudgets :: PurposeUnits -> PurposeUnits -> [Text]
missingPurposeBudgets PurposeUnits
measured PurposeUnits
declared =
    PurposeUnits -> [Text]
forall k a. Map k a -> [k]
Map.keys (PurposeUnits
measured PurposeUnits -> PurposeUnits -> PurposeUnits
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` PurposeUnits
declared)

overBudgetPurposes :: PurposeUnits -> PurposeUnits -> [Text]
overBudgetPurposes :: PurposeUnits -> PurposeUnits -> [Text]
overBudgetPurposes PurposeUnits
measured PurposeUnits
declared =
    [ Text
purpose
    | (Text
purpose, (Integer
measuredMem, Integer
measuredCpu)) <- PurposeUnits -> [(Text, (Integer, Integer))]
forall k a. Map k a -> [(k, a)]
Map.toList PurposeUnits
measured
    , Just (Integer
declaredMem, Integer
declaredCpu) <- [Text -> PurposeUnits -> Maybe (Integer, Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
purpose PurposeUnits
declared]
    , Integer
measuredMem Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
declaredMem Bool -> Bool -> Bool
|| Integer
measuredCpu Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
declaredCpu
    ]