{-# LANGUAGE TypeApplications #-}

module Test.Ouroboros.Storage.LedgerDB.Serialisation (tests) where

import Codec.CBOR.FlatTerm
  ( FlatTerm
  , TermToken (..)
  , fromFlatTerm
  , toFlatTerm
  )
import Codec.Serialise (decode, encode)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import Test.Tasty
import Test.Tasty.HUnit
import Test.Util.Orphans.Arbitrary ()
import Test.Util.TestBlock

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Serialisation"
    [ String -> Assertion -> TestTree
testCase String
"encode" Assertion
test_encode_ledger
    , String -> Assertion -> TestTree
testCase String
"decode" Assertion
test_decode_ledger
    , String -> Assertion -> TestTree
testCase String
"decode ChainSummary" Assertion
test_decode_ChainSummary
    ]

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

-- | The LedgerDB is parametric in the ledger @l@. We use @Int@ for simplicity.
example_ledger :: Int
example_ledger :: Int
example_ledger = Int
100

golden_ledger :: FlatTerm
golden_ledger :: FlatTerm
golden_ledger =
  [ Word -> TermToken
TkListLen Word
2
  , -- VersionNumber
    Int -> TermToken
TkInt Int
1
  , -- ledger: Int
    Int -> TermToken
TkInt Int
100
  ]

-- | The old format based on the @ChainSummary@. To remain backwards compatible
-- we still accept this old format.
golden_ChainSummary :: FlatTerm
golden_ChainSummary :: FlatTerm
golden_ChainSummary =
  [ Word -> TermToken
TkListLen Word
3
  , -- tip: WithOrigin (RealPoint TestBlock)
    Word -> TermToken
TkListLen Word
1
  , Word -> TermToken
TkListLen Word
2
  , Int -> TermToken
TkInt Int
3
  , TermToken
TkListBegin
  , Int -> TermToken
TkInt Int
0
  , Int -> TermToken
TkInt Int
0
  , TermToken
TkBreak
  , -- chain length: Word64
    Int -> TermToken
TkInt Int
10
  , -- ledger: Int for simplicity
    Int -> TermToken
TkInt Int
100
  ]

test_encode_ledger :: Assertion
test_encode_ledger :: Assertion
test_encode_ledger =
  Encoding -> FlatTerm
toFlatTerm (Int -> Encoding
enc Int
example_ledger) FlatTerm -> FlatTerm -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= FlatTerm
golden_ledger
 where
  enc :: Int -> Encoding
enc = (Int -> Encoding) -> Int -> Encoding
forall l. (l -> Encoding) -> l -> Encoding
encodeL Int -> Encoding
forall a. Serialise a => a -> Encoding
encode

test_decode_ledger :: Assertion
test_decode_ledger :: Assertion
test_decode_ledger =
  (forall s. Decoder s Int) -> FlatTerm -> Either String Int
forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
fromFlatTerm Decoder s Int
forall s. Decoder s Int
dec FlatTerm
golden_ledger Either String Int -> Either String Int -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Int -> Either String Int
forall a b. b -> Either a b
Right Int
example_ledger
 where
  dec :: Decoder s Int
dec = Proxy TestBlock
-> (forall s. Decoder s Int)
-> (forall s. Decoder s (HeaderHash TestBlock))
-> forall s. Decoder s Int
forall l blk.
Proxy blk
-> (forall s. Decoder s l)
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s l
decodeLBackwardsCompatible (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @TestBlock) Decoder s Int
forall s. Decoder s Int
forall a s. Serialise a => Decoder s a
decode Decoder s (HeaderHash TestBlock)
Decoder s TestHash
forall s. Decoder s (HeaderHash TestBlock)
forall s. Decoder s TestHash
forall a s. Serialise a => Decoder s a
decode

-- | For backwards compatibility
test_decode_ChainSummary :: Assertion
test_decode_ChainSummary :: Assertion
test_decode_ChainSummary =
  (forall s. Decoder s Int) -> FlatTerm -> Either String Int
forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
fromFlatTerm Decoder s Int
forall s. Decoder s Int
dec FlatTerm
golden_ChainSummary Either String Int -> Either String Int -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Int -> Either String Int
forall a b. b -> Either a b
Right Int
example_ledger
 where
  dec :: Decoder s Int
dec = Proxy TestBlock
-> (forall s. Decoder s Int)
-> (forall s. Decoder s (HeaderHash TestBlock))
-> forall s. Decoder s Int
forall l blk.
Proxy blk
-> (forall s. Decoder s l)
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s l
decodeLBackwardsCompatible (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @TestBlock) Decoder s Int
forall s. Decoder s Int
forall a s. Serialise a => Decoder s a
decode Decoder s (HeaderHash TestBlock)
Decoder s TestHash
forall s. Decoder s (HeaderHash TestBlock)
forall s. Decoder s TestHash
forall a s. Serialise a => Decoder s a
decode