{- | The registration comparison, as one named thing.

This is the comparison the registration chapter has always run, moved out of the
runner so that what it covers can be stated and checked rather than inferred by
reading it. The semantics are unchanged: the delivery observation and the
holder's quantity are each compared with the model's expected observation, and
the registration fails if either differs.

What is new is that the result says which of the model's __declared__
observations it accounted for, and which names the model cannot observe it
carried. Both are derived from the comparison that actually ran — the compared
objects' own fields, intersected with the declared surface — so a comparison
that covers a projection cannot report otherwise.
-}
module Conformance.Compare.Registration
    ( Declared (..)
    , Delivery (..)
    , Difference (..)
    , Agreement (..)
    , declaredSurface
    , deliveryObservation
    , compareRegistration
    , outputFloorAgrees
    , rootOf
    , approvalAssetName
    , edgeOrdinal
    ) where

import Data.Aeson (Value (..), encode, object, (.:), (.=))
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KM
import Data.Aeson.Types (parseEither)
import Data.Bits (shiftR, xor, (.&.))
import Data.List (sort, sortOn)
import Data.Maybe (fromMaybe, isNothing)
import Data.Text (Text)
import Data.Vector qualified as V
import Data.Word (Word64, Word8)

-- | What the model says it can see, read off the driver surface.
data Declared = Declared
    { Declared -> [Text]
declaredObservations :: [Text]
    -- ^ every observation a comparison result must account for
    , Declared -> [Text]
declaredUnobservable :: [Text]
    -- ^ names the model has no vocabulary for; these never earn a pass
    }
    deriving (Declared -> Declared -> Bool
(Declared -> Declared -> Bool)
-> (Declared -> Declared -> Bool) -> Eq Declared
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Declared -> Declared -> Bool
== :: Declared -> Declared -> Bool
$c/= :: Declared -> Declared -> Bool
/= :: Declared -> Declared -> Bool
Eq, Int -> Declared -> ShowS
[Declared] -> ShowS
Declared -> String
(Int -> Declared -> ShowS)
-> (Declared -> String) -> ([Declared] -> ShowS) -> Show Declared
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Declared -> ShowS
showsPrec :: Int -> Declared -> ShowS
$cshow :: Declared -> String
show :: Declared -> String
$cshowList :: [Declared] -> ShowS
showList :: [Declared] -> ShowS
Show)

-- | The delivery the registration chapter presents to the model, in model ids.
data Delivery = Delivery
    { Delivery -> Integer
deliveryAddress :: Integer
    , Delivery -> Integer
deliveryPolicy :: Integer
    , Delivery -> Integer
deliveryKey :: Integer
    , Delivery -> Integer
deliveryQuantity :: Integer
    }
    deriving (Delivery -> Delivery -> Bool
(Delivery -> Delivery -> Bool)
-> (Delivery -> Delivery -> Bool) -> Eq Delivery
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Delivery -> Delivery -> Bool
== :: Delivery -> Delivery -> Bool
$c/= :: Delivery -> Delivery -> Bool
/= :: Delivery -> Delivery -> Bool
Eq, Int -> Delivery -> ShowS
[Delivery] -> ShowS
Delivery -> String
(Int -> Delivery -> ShowS)
-> (Delivery -> String) -> ([Delivery] -> ShowS) -> Show Delivery
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Delivery -> ShowS
showsPrec :: Int -> Delivery -> ShowS
$cshow :: Delivery -> String
show :: Delivery -> String
$cshowList :: [Delivery] -> ShowS
showList :: [Delivery] -> ShowS
Show)

-- | One disagreement, named by the model field it is about.
data Difference = Difference
    { Difference -> Text
differenceObservation :: Text
    , Difference -> Value
differenceExpected :: Value
    , Difference -> Value
differenceObserved :: Value
    }
    deriving (Difference -> Difference -> Bool
(Difference -> Difference -> Bool)
-> (Difference -> Difference -> Bool) -> Eq Difference
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Difference -> Difference -> Bool
== :: Difference -> Difference -> Bool
$c/= :: Difference -> Difference -> Bool
/= :: Difference -> Difference -> Bool
Eq, Int -> Difference -> ShowS
[Difference] -> ShowS
Difference -> String
(Int -> Difference -> ShowS)
-> (Difference -> String)
-> ([Difference] -> ShowS)
-> Show Difference
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Difference -> ShowS
showsPrec :: Int -> Difference -> ShowS
$cshow :: Difference -> String
show :: Difference -> String
$cshowList :: [Difference] -> ShowS
showList :: [Difference] -> ShowS
Show)

-- | What a comparison established, and what it deliberately did not.
data Agreement = Agreement
    { Agreement -> [Text]
agreementCompared :: [Text]
    -- ^ declared observations this comparison actually accounted for
    , Agreement -> [Text]
agreementUnobserved :: [Text]
    -- ^ declared unobservable names the result carried, never compared
    }
    deriving (Agreement -> Agreement -> Bool
(Agreement -> Agreement -> Bool)
-> (Agreement -> Agreement -> Bool) -> Eq Agreement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Agreement -> Agreement -> Bool
== :: Agreement -> Agreement -> Bool
$c/= :: Agreement -> Agreement -> Bool
/= :: Agreement -> Agreement -> Bool
Eq, Int -> Agreement -> ShowS
[Agreement] -> ShowS
Agreement -> String
(Int -> Agreement -> ShowS)
-> (Agreement -> String)
-> ([Agreement] -> ShowS)
-> Show Agreement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Agreement -> ShowS
showsPrec :: Int -> Agreement -> ShowS
$cshow :: Agreement -> String
show :: Agreement -> String
$cshowList :: [Agreement] -> ShowS
showList :: [Agreement] -> ShowS
Show)

-- | Read the declared surface out of a driver corpus value.
declaredSurface :: Value -> Either String Declared
declaredSurface :: Value -> Either String Declared
declaredSurface = (Value -> Parser Declared) -> Value -> Either String Declared
forall a b. (a -> Parser b) -> a -> Either String b
parseEither ((Value -> Parser Declared) -> Value -> Either String Declared)
-> (Value -> Parser Declared) -> Value -> Either String Declared
forall a b. (a -> b) -> a -> b
$ \Value
value -> do
    surface <- case Value
value of
        Object Object
fields -> Object
fields Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"surface"
        Value
_ -> String -> Parser Object
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"driver corpus is not an object"
    observations <- surface .: "observations"
    unobservable <- surface .: "unobservable"
    pure
        Declared
            { declaredObservations = observations
            , declaredUnobservable = unobservable
            }

-- | Exactly the object this chapter has always compared.
deliveryObservation :: Delivery -> Value
deliveryObservation :: Delivery -> Value
deliveryObservation Delivery
delivery =
    [Pair] -> Value
object
        [ Key
"address" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Delivery -> Integer
deliveryAddress Delivery
delivery
        , Key
"policy" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Delivery -> Integer
deliveryPolicy Delivery
delivery
        , Key
"key" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Delivery -> Integer
deliveryKey Delivery
delivery
        , Key
"quantity" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Delivery -> Integer
deliveryQuantity Delivery
delivery
        ]

{- | Compare an observed registration with the model's declared boundary.

Both sides are an @observations@ object in the model's vocabulary: the expected
one from the driver corpus row, the observed one translated from the chain.

Every declared observation must be present on both sides and must agree. A name
the model cannot observe must not appear at all: an observed object that carried
one would be claiming to have seen what the model has no vocabulary for, so it
is reported rather than passed over. Those names are carried in the result,
never compared. The model states lovelace as floors: every observed output's
`lovelace` in `tx`, and every payment's `value` in `paid` and in `tx.refunds`,
must be at least the corresponding model value. Surplus is allowed while every
other field, and the number and order of outputs and payments, is compared for
equality.
-}
compareRegistration
    :: Declared -> Value -> Value -> Either [Difference] Agreement
compareRegistration :: Declared -> Value -> Value -> Either [Difference] Agreement
compareRegistration Declared
declared Value
expected Value
observed =
    case [Difference]
claimed [Difference] -> [Difference] -> [Difference]
forall a. Semigroup a => a -> a -> a
<> [Difference]
missing [Difference] -> [Difference] -> [Difference]
forall a. Semigroup a => a -> a -> a
<> [Difference]
disagreeing of
        [] ->
            Agreement -> Either [Difference] Agreement
forall a b. b -> Either a b
Right
                Agreement
                    { agreementCompared :: [Text]
agreementCompared = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort (Declared -> [Text]
declaredObservations Declared
declared)
                    , agreementUnobserved :: [Text]
agreementUnobserved = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort (Declared -> [Text]
declaredUnobservable Declared
declared)
                    }
        [Difference]
differences -> [Difference] -> Either [Difference] Agreement
forall a b. a -> Either a b
Left [Difference]
differences
  where
    fieldsOf :: Value -> [Text]
fieldsOf Value
value = case Value
value of
        Object Object
fields -> (Key -> Text) -> [Key] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Text
Key.toText (Object -> [Key]
forall v. KeyMap v -> [Key]
KM.keys Object
fields)
        Value
_ -> []
    at :: Text -> Value -> Maybe Value
at Text
name Value
value = case Value
value of
        Object Object
fields -> Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
Key.fromText Text
name) Object
fields
        Value
_ -> Maybe Value
forall a. Maybe a
Nothing
    -- Claiming to have observed something the model cannot observe.
    claimed :: [Difference]
claimed =
        [ Text -> Value -> Value -> Difference
Difference Text
name Value
Null (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value -> Maybe Value
at Text
name Value
observed))
        | Text
name <- [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort (Declared -> [Text]
declaredUnobservable Declared
declared)
        , Text
name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Value -> [Text]
fieldsOf Value
observed
        ]
    -- A declared observation absent from either side is not accounted for.
    missing :: [Difference]
missing =
        [ Text -> Value -> Value -> Difference
Difference
            Text
name
            (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value -> Maybe Value
at Text
name Value
expected))
            (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> Value -> Maybe Value
at Text
name Value
observed))
        | Text
name <- [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort (Declared -> [Text]
declaredObservations Declared
declared)
        , Maybe Value -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> Value -> Maybe Value
at Text
name Value
expected) Bool -> Bool -> Bool
|| Maybe Value -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> Value -> Maybe Value
at Text
name Value
observed)
        ]
    disagreeing :: [Difference]
disagreeing =
        [ Text -> Value -> Value -> Difference
Difference Text
name Value
left Value
right
        | Text
name <- [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort (Declared -> [Text]
declaredObservations Declared
declared)
        , Just Value
left <- [Text -> Value -> Maybe Value
at Text
name Value
expected]
        , Just Value
right <- [Text -> Value -> Maybe Value
at Text
name Value
observed]
        , Bool -> Bool
not (Text -> Value -> Value -> Bool
agrees Text
name Value
left Value
right)
        ]
    agrees :: Text -> Value -> Value -> Bool
agrees Text
"tx" Value
expectedTx Value
observedTx = Value -> Value -> Bool
transactionAgrees Value
expectedTx Value
observedTx
    agrees Text
"paid" Value
expectedPaid Value
observedPaid = Key -> Value -> Value -> Bool
floorsAgree Key
"value" Value
expectedPaid Value
observedPaid
    agrees Text
name Value
expectedValue Value
observedValue =
        Text -> Value -> Value
comparable Text
name Value
expectedValue Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Value -> Value
comparable Text
name Value
observedValue
    transactionAgrees :: Value -> Value -> Bool
transactionAgrees Value
expectedTx Value
observedTx = case (Value
expectedTx, Value
observedTx) of
        (Object Object
expectedFields, Object Object
observedFields) ->
            case ( Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"outputs" Object
expectedFields
                 , Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"outputs" Object
observedFields
                 , Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"refunds" Object
expectedFields
                 , Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"refunds" Object
observedFields
                 ) of
                ( Just Value
expectedOutputs
                    , Just Value
observedOutputs
                    , Just Value
expectedRefunds
                    , Just Value
observedRefunds
                    ) ->
                        Key -> Value -> Value -> Bool
floorsAgree Key
"lovelace" Value
expectedOutputs Value
observedOutputs
                            Bool -> Bool -> Bool
&& Key -> Value -> Value -> Bool
floorsAgree Key
"value" Value
expectedRefunds Value
observedRefunds
                            Bool -> Bool -> Bool
&& Value -> Value
stripFloors Value
expectedTx Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Value
stripFloors Value
observedTx
                (Maybe Value, Maybe Value, Maybe Value, Maybe Value)
_ -> Bool
False
        (Value, Value)
_ -> Bool
False
    -- Two lists of objects agree when they have the same length, each
    -- observed @field@ reaches the model's, and everything else is equal.
    floorsAgree :: Key -> Value -> Value -> Bool
floorsAgree Key
field Value
expectedValue Value
observedValue = case (Value
expectedValue, Value
observedValue) of
        (Array Vector Value
expectedEntries, Array Vector Value
observedEntries) ->
            Vector Value -> Int
forall a. Vector a -> Int
V.length Vector Value
expectedEntries Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Vector Value -> Int
forall a. Vector a -> Int
V.length Vector Value
observedEntries
                Bool -> Bool -> Bool
&& Vector Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Value -> Value -> Bool)
-> Vector Value -> Vector Value -> Vector Bool
forall a b c. (a -> b -> c) -> Vector a -> Vector b -> Vector c
V.zipWith (Key -> Value -> Value -> Bool
floorMet Key
field) Vector Value
expectedEntries Vector Value
observedEntries)
                Bool -> Bool -> Bool
&& (Value -> Value) -> Vector Value -> Vector Value
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key -> Value -> Value
without Key
field) Vector Value
expectedEntries
                    Vector Value -> Vector Value -> Bool
forall a. Eq a => a -> a -> Bool
== (Value -> Value) -> Vector Value -> Vector Value
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key -> Value -> Value
without Key
field) Vector Value
observedEntries
        (Value, Value)
_ -> Bool
False
    floorMet :: Key -> Value -> Value -> Bool
floorMet Key
field Value
expectedEntry Value
observedEntry = case (Value
expectedEntry, Value
observedEntry) of
        (Object Object
expectedFields, Object Object
observedFields) ->
            case (Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
field Object
expectedFields, Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
field Object
observedFields) of
                (Just Value
modelFloor, Just Value
observedAmount) ->
                    Value -> Value -> Bool
outputFloorAgrees Value
modelFloor Value
observedAmount
                (Maybe Value, Maybe Value)
_ -> Bool
False
        (Value, Value)
_ -> Bool
False
    stripFloors :: Value -> Value
stripFloors Value
value = case Value
value of
        Object Object
fields ->
            Object -> Value
Object
                ( (Value -> Value) -> Key -> Object -> Object
forall {v}. (v -> v) -> Key -> KeyMap v -> KeyMap v
adjust
                    ((Value -> Value) -> Value -> Value
withEntries (Key -> Value -> Value
without Key
"value"))
                    Key
"refunds"
                    ((Value -> Value) -> Key -> Object -> Object
forall {v}. (v -> v) -> Key -> KeyMap v -> KeyMap v
adjust ((Value -> Value) -> Value -> Value
withEntries (Key -> Value -> Value
without Key
"lovelace")) Key
"outputs" Object
fields)
                )
        Value
_ -> Value
value
    adjust :: (v -> v) -> Key -> KeyMap v -> KeyMap v
adjust v -> v
f Key
name KeyMap v
fields = case Key -> KeyMap v -> Maybe v
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
name KeyMap v
fields of
        Just v
inner -> Key -> v -> KeyMap v -> KeyMap v
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert Key
name (v -> v
f v
inner) KeyMap v
fields
        Maybe v
Nothing -> KeyMap v
fields
    withEntries :: (Value -> Value) -> Value -> Value
withEntries Value -> Value
f Value
value = case Value
value of
        Array Vector Value
entries -> Vector Value -> Value
Array ((Value -> Value) -> Vector Value -> Vector Value
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
f Vector Value
entries)
        Value
_ -> Value
value
    without :: Key -> Value -> Value
without Key
field Value
value = case Value
value of
        Object Object
fields -> Object -> Value
Object (Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KM.delete Key
field Object
fields)
        Value
_ -> Value
value
    comparable :: Text -> Value -> Value
comparable = Text -> Value -> Value
forall {a}. (Eq a, IsString a) => a -> Value -> Value
heldAsMultiset
    -- Neither the model nor the chain orders a wallet's holdings, so `held`,
    -- alone and inside `state`, is compared as a multiset.
    heldAsMultiset :: a -> Value -> Value
heldAsMultiset a
name Value
value = case (a
name, Value
value) of
        (a
"held", Array Vector Value
holdings) -> Vector Value -> Value
Array (Vector Value -> Vector Value
sortHoldings Vector Value
holdings)
        (a
"state", Object Object
fields) -> case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"held" Object
fields of
            Just (Array Vector Value
holdings) ->
                Object -> Value
Object (Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert Key
"held" (Vector Value -> Value
Array (Vector Value -> Vector Value
sortHoldings Vector Value
holdings)) Object
fields)
            Maybe Value
_ -> Value
value
        (a, Value)
_ -> Value
value
    sortHoldings :: Vector Value -> Vector Value
sortHoldings = [Value] -> Vector Value
forall a. [a] -> Vector a
V.fromList ([Value] -> Vector Value)
-> (Vector Value -> [Value]) -> Vector Value -> Vector Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> ByteString) -> [Value] -> [Value]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode ([Value] -> [Value])
-> (Vector Value -> [Value]) -> Vector Value -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Value -> [Value]
forall a. Vector a -> [a]
V.toList

{- | The shared acceptance rule for one lovelace floor the model states: an
output's lovelace or a payment's value.
-}
outputFloorAgrees :: Value -> Value -> Bool
outputFloorAgrees :: Value -> Value -> Bool
outputFloorAgrees Value
expected Value
observed = case (Value
expected, Value
observed) of
    (Number Scientific
modelFloor, Number Scientific
observedLovelace) -> Scientific
observedLovelace Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
>= Scientific
modelFloor
    (Value, Value)
_ -> Bool
False

{- | @Singular.rootOf@: FNV-1a over the sorted (key, leaf byte) pairs.

A second site computing a model function, so it is not trusted on sight: a
control requires it to reproduce every accepted corpus row's root from that
row's own trie.
-}
rootOf :: [(Integer, Word8)] -> [Word8]
rootOf :: [(Integer, Word8)] -> [Word8]
rootOf [(Integer, Word8)]
leaves = Word64 -> [Word8]
u64bytes ([Word8] -> Word64
fnv1a (((Integer, Word8) -> [Word8]) -> [(Integer, Word8)] -> [Word8]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Integer, Word8) -> [Word8]
forall {a}. Integral a => (a, Word8) -> [Word8]
commit (((Integer, Word8) -> Integer)
-> [(Integer, Word8)] -> [(Integer, Word8)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Integer, Word8) -> Integer
forall a b. (a, b) -> a
fst [(Integer, Word8)]
leaves)))
  where
    commit :: (a, Word8) -> [Word8]
commit (a
key, Word8
leaf) =
        let byte :: Word8
byte = a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
key a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
256)
        in  Word64 -> [Word8]
u64bytes ([Word8] -> Word64
fnv1a [Word8
byte]) [Word8] -> [Word8] -> [Word8]
forall a. Semigroup a => a -> a -> a
<> [Word8
byte, Word8
leaf]

fnv1a :: [Word8] -> Word64
fnv1a :: [Word8] -> Word64
fnv1a = (Word64 -> Word8 -> Word64) -> Word64 -> [Word8] -> Word64
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Word64 -> Word8 -> Word64
forall {a} {a}. (Bits a, Integral a, Num a) => a -> a -> a
step Word64
14695981039346656037
  where
    step :: a -> a -> a
step a
accumulator a
byte = (a
accumulator a -> a -> a
forall a. Bits a => a -> a -> a
`xor` a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
byte) a -> a -> a
forall a. Num a => a -> a -> a
* a
16777619

u64bytes :: Word64 -> [Word8]
u64bytes :: Word64 -> [Word8]
u64bytes Word64
value =
    [ Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
value Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
place) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xFF)
    | Int
place <- [Int
56, Int
48, Int
40, Int
32, Int
24, Int
16, Int
8, Int
0]
    ]

-- | @Singular.edgeOrdinal@: the byte each edge commits under.
edgeOrdinal :: Text -> Maybe Word8
edgeOrdinal :: Text -> Maybe Word8
edgeOrdinal Text
edge = Text -> [(Text, Word8)] -> Maybe Word8
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
edge [(Text, Word8)]
table
  where
    table :: [(Text, Word8)]
table =
        [ (Text
"insertAbsent", Word8
0)
        , (Text
"insertActive", Word8
1)
        , (Text
"updateActive", Word8
2)
        , (Text
"updateTerminal", Word8
3)
        , (Text
"deleteAbsent", Word8
4)
        , (Text
"deleteActive", Word8
5)
        , (Text
"witnessTerminal", Word8
6)
        ]

{- | @Singular.approvalAssetName@, which @datumHash@ also is.

FNV-1a over the scoping tuple, masked to 32 bits: the model's stand-in for
@blake2b_256(edge ‖ key ‖ owner ‖ destination)@. A second site computing a model
function, so like 'rootOf' it is not trusted on sight — a control requires it to
reproduce every approval asset name and destination commitment in the committed
corpus, from that row's own request.
-}
approvalAssetName
    :: Text -> Integer -> Integer -> Integer -> Maybe Integer
approvalAssetName :: Text -> Integer -> Integer -> Integer -> Maybe Integer
approvalAssetName Text
edge Integer
key Integer
owner Integer
destination = do
    ordinal <- Text -> Maybe Word8
edgeOrdinal Text
edge
    let byte a
value = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
value a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
256)
    pure
        ( fromIntegral
            (fnv1a [ordinal, byte key, byte owner, byte destination] .&. 0xFFFFFFFF)
        )