SerializationSpec.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- | The serialization slice: the versioned binary envelope and its refusals.
module Moonlight.Triangulation.SerializationSpec (tests) where

import Control.DeepSeq (NFData)
import Control.Monad (forM_, unless)
import Data.Binary (Binary)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Vector as V
import GHC.Generics (Generic)
import Moonlight.Triangulation
import Moonlight.Triangulation.Serialization
import Support (assertEqual, assertValid, requireRight)

tests :: IO ()
tests = do
  testRoundTrip
  testIndependentPayloadGeometryRoundTrip
  testPointPayloadRoundTrip
  testRejectsCorruption
  putStrLn "all serialization tests passed"

data SerialVertex = SerialVertex
  { serialPosition :: !(Point)
  , serialLabel :: !Int
  }
  deriving stock (Eq, Show, Generic)
  deriving anyclass (NFData, Binary)

instance HasPosition SerialVertex where
  position = serialPosition

type SerialTriangulation = Triangulation 'Unconstrained SerialVertex Int Bool String

source :: IO SerialTriangulation
source = do
  let defaults = ElementDefaults (3 :: Int) True ("face" :: String)
      payloads =
        V.fromList
          [ SerialVertex (Point 0 0) 10
          , SerialVertex (Point 2 0) 20
          , SerialVertex (Point 0 2) 30
          , SerialVertex (Point 0.5 0.5) 40
          ]
  buildTriangulation <$> requireRight "serialization source" (delaunay defaults payloads)

testRoundTrip :: IO ()
testRoundTrip = do
  original <- source
  let bytes = encodeTriangulation original
  unless (BL.length bytes > 0) $ fail "serialization produced an empty payload"
  roundTrip <- requireRight "serialization round trip" (decodeTriangulation bytes :: Either SerializationError SerialTriangulation)
  assertEqual "serialization equality" original roundTrip
  assertValid "serialization round trip" roundTrip

-- Vertex payload positions are annotations after ingestion. Serialization must
-- therefore preserve the fixed geometry and the independently edited payload,
-- rather than letting the latter reauthor the former on decode.
testIndependentPayloadGeometryRoundTrip :: IO ()
testIndependentPayloadGeometryRoundTrip = do
  geometry <- source
  vertex <- case vertices geometry of
    (first : _) -> pure first
    [] -> fail "independent payload fixture has no vertices"
  let independentPayload = SerialVertex (Point 91 73) 1010
      original = setVertexData geometry vertex independentPayload
      positionless = mapVertices serialLabel original
  assertEqual "independent payload leaves geometry fixed"
    (vertexPoint geometry vertex) (vertexPoint original vertex)
  assertEqual "independent payload position is stored"
    (Point 91 73) (serialPosition (vertexData original vertex))
  roundTrip <-
    requireRight
      "independent payload serialization"
      (decodeTriangulation (encodeTriangulation original) :: Either SerializationError SerialTriangulation)
  assertEqual "independent geometry, payload, and topology round trip" original roundTrip
  assertValid "independent payload serialization" roundTrip
  positionlessRoundTrip <-
    requireRight
      "positionless payload serialization"
      (decodeTriangulation (encodeTriangulation positionless) :: Either SerializationError (Triangulation 'Unconstrained Int Int Bool String))
  assertEqual "positionless payload round trip" positionless positionlessRoundTrip
  assertValid "positionless payload serialization" positionlessRoundTrip

testPointPayloadRoundTrip :: IO ()
testPointPayloadRoundTrip = do
  let points = V.fromList [Point 0 0, Point 2 0, Point 0 2, Point 0.5 0.5] :: V.Vector (Point)
  built <- requireRight "point payload source" (delaunay unitElementDefaults points)
  let geometry = buildTriangulation built
  vertex <- case vertices geometry of
    (first : _) -> pure first
    [] -> fail "point payload fixture has no vertices"
  let original = setVertexData geometry vertex (Point 13 17)
  assertEqual "point payload leaves geometry fixed"
    (vertexPoint geometry vertex) (vertexPoint original vertex)
  assertEqual "point payload is stored"
    (Point 13 17) (vertexData original vertex)
  roundTrip <-
    requireRight
      "point payload serialization"
      (decodeTriangulation (encodeTriangulation original) :: Either SerializationError (Triangulation 'Unconstrained (Point) () () ()))
  assertEqual "point payload serialization equality" original roundTrip
  assertValid "point payload serialization round trip" roundTrip

-- The header is the part of the stream that is structurally constrained: magic,
-- version, constraint mode and coordinate encoding each have exactly one admissible
-- byte pattern, so every mutation of them must be refused. Beyond the header
-- the stream carries payload values, and a byte flipped inside an element
-- payload names a different but entirely legal value — the guarantee there is
-- not refusal but soundness: a decoder that rebuilds its indexes rather than
-- trusting them may never surface a triangulation that violates its invariants,
-- whatever it is fed.
testRejectsCorruption :: IO ()
testRejectsCorruption = do
  original <- source
  let bytes = encodeTriangulation original
      size = BL.length bytes
      headerSize = 8 + 2 + 1 + 1
      decode candidate = decodeTriangulation candidate :: Either SerializationError SerialTriangulation
      flipAt offset =
        BL.concat [BL.take offset bytes, BL.singleton (BL.index bytes offset + 1), BL.drop (offset + 1) bytes]
      rejects :: String -> BL.ByteString -> IO ()
      rejects label candidate =
        case decode candidate of
          Left _ -> pure ()
          Right _ -> fail ("decoder accepted " <> label)
  assertEqual
    "typed trailing-byte refusal"
    (Left (TrailingBytes 1))
    (decode (bytes <> BL.singleton 0))
  case decode (BL.cons 0 (BL.drop 1 bytes)) of
    Left (InvalidFormatMagic _) -> pure ()
    other -> fail ("magic corruption produced " <> show other)
  rejects "an empty payload" BL.empty
  forM_ [1 .. size] $ \dropped ->
    rejects ("a payload truncated by " <> show dropped) (BL.take (size - dropped) bytes)
  forM_ [0 .. headerSize - 1] $ \offset ->
    rejects ("a header byte flipped at offset " <> show offset) (flipAt offset)
  forM_ [headerSize .. size - 1] $ \offset ->
    case decode (flipAt offset) of
      Left _ -> pure ()
      Right decoded ->
        assertValid ("a byte flipped at offset " <> show offset <> " decoded to") decoded