{- |
Module      : Singular.Registry.Proof
Description : Aiken-compatible proof serialization
License     : Apache-2.0

Serializes 'MPFProof' (from @mts:mpf@)
to the CBOR\/PlutusData format expected by the Aiken
on-chain validator, and converts proofs to the on-chain
'ProofStep' type used in 'UpdateRedeemer'.

The CBOR encoding uses indefinite-length lists and
bytestrings to match the reference TypeScript
implementation byte-for-byte. Steps are reversed from
the library's leaf-to-root order to the root-to-leaf
order expected on-chain.
-}
module Singular.Registry.Proof
    ( -- * Serialization
      serializeProof

      -- * Conversion to on-chain types
    , toProofSteps
    ) where

import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Builder
    ( Builder
    , byteString
    , toLazyByteString
    , word8
    )
import Data.ByteString.Lazy qualified as BL
import Data.Map.Strict qualified as Map
import Data.Word (Word8)
import MPF.Hashes
    ( MPFHash
    , merkleProof
    , nibbleBytes
    , packHexKey
    , renderMPFHash
    )
import MPF.Interface (HexDigit (..))
import MPF.Proof.Insertion
    ( MPFProof (..)
    , MPFProofStep (..)
    )

import Singular.Registry.Types
    ( Neighbor (..)
    , ProofStep (..)
    )

{- | Serialize an 'MPFProof' to Aiken-compatible
PlutusData CBOR bytes.

The output is byte-identical to the TypeScript
reference @proof.toCBOR()@.
-}
serializeProof
    :: MPFProof MPFHash
    -- ^ Proof produced by an insert\/delete\/update
    -> ByteString
serializeProof :: MPFProof MPFHash -> ByteString
serializeProof MPFProof{[MPFProofStep MPFHash]
mpfProofSteps :: [MPFProofStep MPFHash]
mpfProofSteps :: forall a. MPFProof a -> [MPFProofStep a]
mpfProofSteps} =
    LazyByteString -> ByteString
BL.toStrict
        (LazyByteString -> ByteString)
-> (Builder -> LazyByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
toLazyByteString
        (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder
cborBeginList
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
                -- Steps are stored leaf-to-root for
                -- foldl'; CBOR needs root-to-leaf.
                ((MPFProofStep MPFHash -> Builder)
-> [MPFProofStep MPFHash] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map MPFProofStep MPFHash -> Builder
encodeStep ([MPFProofStep MPFHash] -> [MPFProofStep MPFHash]
forall a. [a] -> [a]
reverse [MPFProofStep MPFHash]
mpfProofSteps))
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cborEnd

-- | Encode a single proof step as PlutusData CBOR.
encodeStep :: MPFProofStep MPFHash -> Builder
encodeStep :: MPFProofStep MPFHash -> Builder
encodeStep
    ( ProofStepBranch
            { HexKey
psbJump :: HexKey
psbJump :: forall a. MPFProofStep a -> HexKey
psbJump
            , HexDigit
psbPosition :: HexDigit
psbPosition :: forall a. MPFProofStep a -> HexDigit
psbPosition
            , [(HexDigit, MPFHash)]
psbSiblingHashes :: [(HexDigit, MPFHash)]
psbSiblingHashes :: forall a. MPFProofStep a -> [(HexDigit, a)]
psbSiblingHashes
            }
        ) =
        -- Aiken: Branch { skip, neighbors }
        -- tag 121 [ skip, indef-bytes neighbors ]
        let skip :: Int
skip = HexKey -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length HexKey
psbJump
            sparseChildren :: [Maybe MPFHash]
sparseChildren =
                [(HexDigit, MPFHash)] -> [Maybe MPFHash]
buildSparse [(HexDigit, MPFHash)]
psbSiblingHashes
            pos :: Int
pos =
                Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HexDigit -> Word8
unHexDigit HexDigit
psbPosition)
            neighborHashes :: [ByteString]
neighborHashes =
                (MPFHash -> ByteString) -> [MPFHash] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map MPFHash -> ByteString
renderMPFHash ([MPFHash] -> [ByteString]) -> [MPFHash] -> [ByteString]
forall a b. (a -> b) -> a -> b
$
                    [Maybe MPFHash] -> Int -> [MPFHash]
merkleProof [Maybe MPFHash]
sparseChildren Int
pos
            -- 4 x 32 = 128 bytes, split into two
            -- 64-byte chunks (matching TypeScript)
            allBytes :: ByteString
allBytes = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ByteString]
neighborHashes
            (ByteString
chunk1, ByteString
chunk2) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
64 ByteString
allBytes
        in  Int -> Builder
cborTag Int
121
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cborBeginList
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
cborInt Int
skip
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cborBeginBytes
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
cborBytes ByteString
chunk1
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
cborBytes ByteString
chunk2
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cborEnd
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cborEnd
encodeStep
    ( ProofStepFork
            { HexKey
psfBranchJump :: HexKey
psfBranchJump :: forall a. MPFProofStep a -> HexKey
psfBranchJump
            , HexKey
psfNeighborPrefix :: HexKey
psfNeighborPrefix :: forall a. MPFProofStep a -> HexKey
psfNeighborPrefix
            , HexDigit
psfNeighborIndex :: HexDigit
psfNeighborIndex :: forall a. MPFProofStep a -> HexDigit
psfNeighborIndex
            , MPFHash
psfMerkleRoot :: MPFHash
psfMerkleRoot :: forall a. MPFProofStep a -> a
psfMerkleRoot
            }
        ) =
        -- Aiken: Fork { skip, neighbor }
        -- tag 122 [ skip, tag 121 [ nibble, prefix,
        --                           root ] ]
        let skip :: Int
skip = HexKey -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length HexKey
psfBranchJump
            nibble :: Int
nibble =
                Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                    (HexDigit -> Word8
unHexDigit HexDigit
psfNeighborIndex)
            prefix :: ByteString
prefix = HexKey -> ByteString
nibbleBytes HexKey
psfNeighborPrefix
            root :: ByteString
root = MPFHash -> ByteString
renderMPFHash MPFHash
psfMerkleRoot
        in  Int -> Builder
cborTag Int
122
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cborBeginList
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
cborInt Int
skip
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
cborTag Int
121
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cborBeginList
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
cborInt Int
nibble
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
cborBytes ByteString
prefix
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
cborBytes ByteString
root
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cborEnd
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cborEnd
encodeStep
    ( ProofStepLeaf
            { HexKey
pslBranchJump :: HexKey
pslBranchJump :: forall a. MPFProofStep a -> HexKey
pslBranchJump
            , HexKey
pslNeighborKeyPath :: HexKey
pslNeighborKeyPath :: forall a. MPFProofStep a -> HexKey
pslNeighborKeyPath
            , MPFHash
pslNeighborValueDigest :: MPFHash
pslNeighborValueDigest :: forall a. MPFProofStep a -> a
pslNeighborValueDigest
            }
        ) =
        -- Aiken: Leaf { skip, key, value }
        -- tag 123 [ skip, key, value ]
        let skip :: Int
skip = HexKey -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length HexKey
pslBranchJump
            key :: ByteString
key = HexKey -> ByteString
packHexKey HexKey
pslNeighborKeyPath
            value :: ByteString
value =
                MPFHash -> ByteString
renderMPFHash MPFHash
pslNeighborValueDigest
        in  Int -> Builder
cborTag Int
123
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cborBeginList
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
cborInt Int
skip
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
cborBytes ByteString
key
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
cborBytes ByteString
value
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cborEnd

{- | Convert an 'MPFProof' to on-chain 'ProofStep's.

Steps are reversed from leaf-to-root storage order
to root-to-leaf (same as 'serializeProof').
-}
toProofSteps
    :: MPFProof MPFHash
    -- ^ Proof produced by an insert\/delete\/update
    -> [ProofStep]
toProofSteps :: MPFProof MPFHash -> [ProofStep]
toProofSteps MPFProof{[MPFProofStep MPFHash]
mpfProofSteps :: forall a. MPFProof a -> [MPFProofStep a]
mpfProofSteps :: [MPFProofStep MPFHash]
mpfProofSteps} =
    (MPFProofStep MPFHash -> ProofStep)
-> [MPFProofStep MPFHash] -> [ProofStep]
forall a b. (a -> b) -> [a] -> [b]
map MPFProofStep MPFHash -> ProofStep
convertStep ([MPFProofStep MPFHash] -> [MPFProofStep MPFHash]
forall a. [a] -> [a]
reverse [MPFProofStep MPFHash]
mpfProofSteps)

{- | Convert a single 'MPFProofStep' to an on-chain
'ProofStep'.
-}
convertStep
    :: MPFProofStep MPFHash -> ProofStep
convertStep :: MPFProofStep MPFHash -> ProofStep
convertStep
    ProofStepBranch
        { HexKey
psbJump :: forall a. MPFProofStep a -> HexKey
psbJump :: HexKey
psbJump
        , HexDigit
psbPosition :: forall a. MPFProofStep a -> HexDigit
psbPosition :: HexDigit
psbPosition
        , [(HexDigit, MPFHash)]
psbSiblingHashes :: forall a. MPFProofStep a -> [(HexDigit, a)]
psbSiblingHashes :: [(HexDigit, MPFHash)]
psbSiblingHashes
        } =
        let skip :: Integer
skip =
                Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HexKey -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length HexKey
psbJump)
            sparseChildren :: [Maybe MPFHash]
sparseChildren =
                [(HexDigit, MPFHash)] -> [Maybe MPFHash]
buildSparse [(HexDigit, MPFHash)]
psbSiblingHashes
            pos :: Int
pos =
                Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                    (HexDigit -> Word8
unHexDigit HexDigit
psbPosition)
            neighborHashes :: [ByteString]
neighborHashes =
                (MPFHash -> ByteString) -> [MPFHash] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map MPFHash -> ByteString
renderMPFHash ([MPFHash] -> [ByteString]) -> [MPFHash] -> [ByteString]
forall a b. (a -> b) -> a -> b
$
                    [Maybe MPFHash] -> Int -> [MPFHash]
merkleProof [Maybe MPFHash]
sparseChildren Int
pos
            neighbors :: ByteString
neighbors = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ByteString]
neighborHashes
        in  Integer -> ByteString -> ProofStep
Branch Integer
skip ByteString
neighbors
convertStep
    ProofStepFork
        { HexKey
psfBranchJump :: forall a. MPFProofStep a -> HexKey
psfBranchJump :: HexKey
psfBranchJump
        , HexKey
psfNeighborPrefix :: forall a. MPFProofStep a -> HexKey
psfNeighborPrefix :: HexKey
psfNeighborPrefix
        , HexDigit
psfNeighborIndex :: forall a. MPFProofStep a -> HexDigit
psfNeighborIndex :: HexDigit
psfNeighborIndex
        , MPFHash
psfMerkleRoot :: forall a. MPFProofStep a -> a
psfMerkleRoot :: MPFHash
psfMerkleRoot
        } =
        let skip :: Integer
skip =
                Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HexKey -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length HexKey
psfBranchJump)
            nibble :: Integer
nibble =
                Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                    (HexDigit -> Word8
unHexDigit HexDigit
psfNeighborIndex)
            prefix :: ByteString
prefix =
                HexKey -> ByteString
nibbleBytes HexKey
psfNeighborPrefix
            root :: ByteString
root = MPFHash -> ByteString
renderMPFHash MPFHash
psfMerkleRoot
        in  Integer -> Neighbor -> ProofStep
Fork
                Integer
skip
                Neighbor
                    { neighborNibble :: Integer
neighborNibble = Integer
nibble
                    , neighborPrefix :: ByteString
neighborPrefix = ByteString
prefix
                    , neighborRoot :: ByteString
neighborRoot = ByteString
root
                    }
convertStep
    ProofStepLeaf
        { HexKey
pslBranchJump :: forall a. MPFProofStep a -> HexKey
pslBranchJump :: HexKey
pslBranchJump
        , HexKey
pslNeighborKeyPath :: forall a. MPFProofStep a -> HexKey
pslNeighborKeyPath :: HexKey
pslNeighborKeyPath
        , MPFHash
pslNeighborValueDigest :: forall a. MPFProofStep a -> a
pslNeighborValueDigest :: MPFHash
pslNeighborValueDigest
        } =
        let skip :: Integer
skip =
                Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HexKey -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length HexKey
pslBranchJump)
            key :: ByteString
key =
                HexKey -> ByteString
packHexKey HexKey
pslNeighborKeyPath
            value :: ByteString
value =
                MPFHash -> ByteString
renderMPFHash MPFHash
pslNeighborValueDigest
        in  Integer -> ByteString -> ByteString -> ProofStep
Leaf Integer
skip ByteString
key ByteString
value

{- | Build a sparse 16-element array from sibling
hashes for 'merkleProof'.
-}
buildSparse
    :: [(HexDigit, MPFHash)] -> [Maybe MPFHash]
buildSparse :: [(HexDigit, MPFHash)] -> [Maybe MPFHash]
buildSparse [(HexDigit, MPFHash)]
siblings =
    let m :: Map HexDigit MPFHash
m = [(HexDigit, MPFHash)] -> Map HexDigit MPFHash
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(HexDigit, MPFHash)]
siblings
    in  [ HexDigit -> Map HexDigit MPFHash -> Maybe MPFHash
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Word8 -> HexDigit
HexDigit Word8
n) Map HexDigit MPFHash
m
        | Word8
n <- [Word8
0 .. Word8
15]
        ]

-- ----------------------------------------------------------
-- Minimal CBOR encoding (PlutusData subset)
--
-- Uses indefinite-length encoding to match the
-- reference TypeScript implementation byte-for-byte.
-- ----------------------------------------------------------

-- | CBOR tag (major type 6).
cborTag :: Int -> Builder
cborTag :: Int -> Builder
cborTag Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
24 = Word8 -> Builder
word8 (Word8
0xc0 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256 =
        Word8 -> Builder
word8 Word8
0xd8 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
word8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
    | Bool
otherwise =
        [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error [Char]
"cborTag: value too large"

-- | Begin an indefinite-length CBOR list.
cborBeginList :: Builder
cborBeginList :: Builder
cborBeginList = Word8 -> Builder
word8 Word8
0x9f

-- | Begin an indefinite-length CBOR bytestring.
cborBeginBytes :: Builder
cborBeginBytes :: Builder
cborBeginBytes = Word8 -> Builder
word8 Word8
0x5f

-- | End an indefinite-length CBOR item.
cborEnd :: Builder
cborEnd :: Builder
cborEnd = Word8 -> Builder
word8 Word8
0xff

-- | CBOR non-negative integer (major type 0).
cborInt :: Int -> Builder
cborInt :: Int -> Builder
cborInt = Word8 -> Int -> Builder
cborMajor Word8
0

-- | CBOR definite-length bytestring (major type 2).
cborBytes :: ByteString -> Builder
cborBytes :: ByteString -> Builder
cborBytes ByteString
bs =
    Word8 -> Int -> Builder
cborMajor Word8
2 (ByteString -> Int
B.length ByteString
bs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
bs

-- | Encode a CBOR major type + argument.
cborMajor :: Word8 -> Int -> Builder
cborMajor :: Word8 -> Int -> Builder
cborMajor Word8
major Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
24 =
        Word8 -> Builder
word8 (Word8
major Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
32 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256 =
        Word8 -> Builder
word8 (Word8
major Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
32 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
24)
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
word8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
65536 =
        Word8 -> Builder
word8 (Word8
major Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
32 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
25)
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
word8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
256))
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
word8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
256))
    | Bool
otherwise =
        [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error [Char]
"cborMajor: value too large"