Compat.hs

{- | Schema compatibility checking in the style of Confluent Schema Registry.

Confluent defines several compatibility levels for schema evolution:

* __BACKWARD__: new schema can read data written by the old schema.
  Consumers can be upgraded before producers.

* __FORWARD__: old schema can read data written by the new schema.
  Producers can be upgraded before consumers.

* __FULL__: both backward and forward compatible.
  Producers and consumers can be upgraded in any order.

* __BACKWARD_TRANSITIVE__: backward compatible with all prior versions.
* __FORWARD_TRANSITIVE__: forward compatible with all prior versions.
* __FULL_TRANSITIVE__: full compatible with all prior versions.
* __NONE__: no compatibility checking.

For protobuf, this translates to checking specific rules about field
additions, removals, type changes, and number reuse.

Backward-compatible changes (new reads old):
* Add a new optional/repeated field
* Remove a field (must be reserved)
* Change a field from required to optional (proto2)

Forward-compatible changes (old reads new):
* Add a new optional/repeated field (old ignores it)
* Remove an optional/repeated field

Breaking changes:
* Change a field's type (different wire type)
* Change a field's number
* Reuse a previously deleted field number without reserving
* Remove a required field (proto2)
* Add a required field (proto2)
* Change between scalar types with different wire formats
* Rename an enum value that's used for JSON encoding
-}
module Proto.Compat (
  -- * Compatibility levels
  CompatLevel (..),

  -- * Compatibility checking
  checkCompat,
  checkCompatAll,

  -- * Compatibility results
  CompatResult (..),
  CompatError (..),
  Severity (..),
  isCompatible,
  compatErrors,

  -- * Individual checks
  checkBackward,
  checkForward,
  checkFull,

  -- * Specific rules
  checkMessageCompat,
  checkEnumCompat,
  checkFieldCompat,

  -- * Direction (for specific rule checks)
  Direction (..),
) where

import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Proto.IDL.AST
import Proto.IDL.Inspect


-- | Compatibility level, matching Confluent Schema Registry semantics.
data CompatLevel
  = None
  | Backward
  | BackwardTransitive
  | Forward
  | ForwardTransitive
  | Full
  | FullTransitive
  deriving stock (Show, Eq, Ord)


-- | Severity of a compatibility issue.
data Severity = Warning | Error
  deriving stock (Show, Eq, Ord)


-- | A single compatibility issue found during schema comparison.
data CompatError = CompatError
  { ceMessage :: !Text
  , cePath :: !Text -- e.g. "Person.name" or "Status.ACTIVE"
  , ceSeverity :: !Severity
  , ceRule :: !Text -- short rule identifier
  }
  deriving stock (Show, Eq)


-- | The result of a compatibility check, containing zero or more errors.
newtype CompatResult = CompatResult
  { crErrors :: [CompatError]
  }
  deriving stock (Show, Eq)


instance Semigroup CompatResult where
  CompatResult a <> CompatResult b = CompatResult (a <> b)


instance Monoid CompatResult where
  mempty = CompatResult []


-- | 'True' when the result contains no errors (warnings are allowed).
isCompatible :: CompatResult -> Bool
isCompatible (CompatResult errs) = not (any (\e -> ceSeverity e == Error) errs)


-- | Extract the list of 'CompatError' entries from a result.
compatErrors :: CompatResult -> [CompatError]
compatErrors = crErrors


-- | Check compatibility between a new schema and the previous version.
checkCompat :: CompatLevel -> ProtoFile -> ProtoFile -> CompatResult
checkCompat level new old = case level of
  None -> mempty
  Backward -> checkBackward new old
  BackwardTransitive -> checkBackward new old
  Forward -> checkForward new old
  ForwardTransitive -> checkForward new old
  Full -> checkFull new old
  FullTransitive -> checkFull new old


-- | Check against all previous versions (transitive).
checkCompatAll :: CompatLevel -> ProtoFile -> [ProtoFile] -> CompatResult
checkCompatAll level new olds = case level of
  None -> mempty
  Backward -> maybe mempty (checkBackward new) (safeHead olds)
  BackwardTransitive -> foldMap (checkBackward new) olds
  Forward -> maybe mempty (checkForward new) (safeHead olds)
  ForwardTransitive -> foldMap (checkForward new) olds
  Full -> maybe mempty (checkFull new) (safeHead olds)
  FullTransitive -> foldMap (checkFull new) olds
  where
    safeHead [] = Nothing
    safeHead (x : _) = Just x


-- | BACKWARD: can the new schema read data written by the old schema?
checkBackward :: ProtoFile -> ProtoFile -> CompatResult
checkBackward new old = checkMessages BackwardDir new old <> checkEnums BackwardDir new old


-- | FORWARD: can the old schema read data written by the new schema?
checkForward :: ProtoFile -> ProtoFile -> CompatResult
checkForward new old = checkMessages ForwardDir new old <> checkEnums ForwardDir new old


-- | FULL: both backward and forward compatible.
checkFull :: ProtoFile -> ProtoFile -> CompatResult
checkFull new old = checkBackward new old <> checkForward new old


-- | Direction of a compatibility check.
data Direction = BackwardDir | ForwardDir
  deriving stock (Show, Eq)


dirLabel :: Direction -> Text
dirLabel BackwardDir = "BACKWARD"
dirLabel ForwardDir = "FORWARD"


-- Message-level checks

checkMessages :: Direction -> ProtoFile -> ProtoFile -> CompatResult
checkMessages dir new old =
  let newMsgs = Map.fromList (fmap (\m -> (msgName m, m)) (allMessages new))
      oldMsgs = Map.fromList (fmap (\m -> (msgName m, m)) (allMessages old))
  in -- Messages present in old but absent in new
     foldMap
       ( \name -> case dir of
           BackwardDir -> mempty
           ForwardDir ->
             makeError
               (dirLabel dir <> ": message '" <> name <> "' was removed")
               name
               Error
               "MESSAGE_REMOVED"
       )
       (Map.keys (Map.difference oldMsgs newMsgs))
       <>
       -- Messages present in both: check field-level compatibility
       Map.foldlWithKey'
         ( \acc name newMsg ->
             case Map.lookup name oldMsgs of
               Nothing -> acc
               Just oldMsg -> acc <> checkMessageCompat dir name newMsg oldMsg
         )
         mempty
         newMsgs


-- | Check field-level compatibility between two versions of a message definition.
checkMessageCompat :: Direction -> Text -> MessageDef -> MessageDef -> CompatResult
checkMessageCompat dir msgPath newMsg oldMsg =
  let newFields = fieldMap newMsg
      oldFields = fieldMap oldMsg
      newNums = Map.keysSet newFields
      oldNums = Map.keysSet oldFields
      reserved = reservedNumbers newMsg
  in -- Fields removed from old
     foldMap
       ( \num ->
           let oldFd = oldFields Map.! num
               path = msgPath <> "." <> fieldName oldFd
           in case dir of
                BackwardDir ->
                  if num `Set.member` reserved
                    then mempty
                    else
                      makeError
                        ( dirLabel dir
                            <> ": field '"
                            <> fieldName oldFd
                            <> "' (number "
                            <> T.pack (show num)
                            <> ") removed without reserving the number"
                        )
                        path
                        Error
                        "FIELD_REMOVED_NOT_RESERVED"
                        <> case fieldLabel oldFd of
                          Just Required ->
                            makeError
                              (dirLabel dir <> ": required field '" <> fieldName oldFd <> "' removed")
                              path
                              Error
                              "REQUIRED_FIELD_REMOVED"
                          _ -> mempty
                ForwardDir -> mempty
       )
       (Set.difference oldNums newNums)
       <>
       -- Fields added in new
       foldMap
         ( \num ->
             let newFd = newFields Map.! num
                 path = msgPath <> "." <> fieldName newFd
             in case dir of
                  BackwardDir -> case fieldLabel newFd of
                    Just Required ->
                      makeError
                        (dirLabel dir <> ": required field '" <> fieldName newFd <> "' added")
                        path
                        Error
                        "REQUIRED_FIELD_ADDED"
                    _ -> mempty
                  ForwardDir -> mempty
         )
         (Set.difference newNums oldNums)
       <>
       -- Fields present in both: check type compatibility
       Map.foldlWithKey'
         ( \acc num newFd ->
             case Map.lookup num oldFields of
               Nothing -> acc
               Just oldFd -> acc <> checkFieldCompat dir msgPath newFd oldFd
         )
         mempty
         newFields
       <>
       -- Number reuse check: field numbers in new that were in old but deleted
       -- and then re-added with a different name
       foldMap
         ( \num ->
             let newFd = newFields Map.! num
                 oldFd = oldFields Map.! num
                 path = msgPath <> "." <> fieldName newFd
             in if fieldName newFd /= fieldName oldFd && not (num `Set.member` reserved)
                  then
                    makeWarning
                      ( dirLabel dir
                          <> ": field number "
                          <> T.pack (show num)
                          <> " changed name from '"
                          <> fieldName oldFd
                          <> "' to '"
                          <> fieldName newFd
                          <> "'"
                      )
                      path
                      "FIELD_NAME_CHANGED"
                  else mempty
         )
         (Set.intersection newNums oldNums)


-- | Check compatibility of a single field.
checkFieldCompat :: Direction -> Text -> FieldDef -> FieldDef -> CompatResult
checkFieldCompat dir msgPath newFd oldFd =
  let path = msgPath <> "." <> fieldName newFd
  in -- Type change
     ( if fieldType newFd /= fieldType oldFd
         then
           if wireCompatible (fieldType newFd) (fieldType oldFd)
             then
               makeWarning
                 ( dirLabel dir
                     <> ": field '"
                     <> fieldName newFd
                     <> "' type changed from "
                     <> showFieldType (fieldType oldFd)
                     <> " to "
                     <> showFieldType (fieldType newFd)
                     <> " (wire-compatible)"
                 )
                 path
                 "FIELD_TYPE_CHANGED_COMPATIBLE"
             else
               makeError
                 ( dirLabel dir
                     <> ": field '"
                     <> fieldName newFd
                     <> "' type changed from "
                     <> showFieldType (fieldType oldFd)
                     <> " to "
                     <> showFieldType (fieldType newFd)
                     <> " (wire-INCOMPATIBLE)"
                 )
                 path
                 Error
                 "FIELD_TYPE_CHANGED_INCOMPATIBLE"
         else mempty
     )
       <>
       -- Label change (required -> optional is OK for backward, not for forward)
       ( case (fieldLabel oldFd, fieldLabel newFd) of
           (Just Required, Just Optional) -> case dir of
             BackwardDir -> mempty
             ForwardDir ->
               makeError
                 ( dirLabel dir
                     <> ": field '"
                     <> fieldName newFd
                     <> "' changed from required to optional"
                 )
                 path
                 Error
                 "REQUIRED_TO_OPTIONAL"
           (Just Optional, Just Required) ->
             makeError
               ( dirLabel dir
                   <> ": field '"
                   <> fieldName newFd
                   <> "' changed from optional to required"
               )
               path
               Error
               "OPTIONAL_TO_REQUIRED"
           (Nothing, Just Required) ->
             makeError
               ( dirLabel dir
                   <> ": field '"
                   <> fieldName newFd
                   <> "' changed to required"
               )
               path
               Error
               "BECAME_REQUIRED"
           _ -> mempty
       )


-- Enum-level checks

checkEnums :: Direction -> ProtoFile -> ProtoFile -> CompatResult
checkEnums dir new old =
  let newEnums = Map.fromList (fmap (\e -> (enumName e, e)) (allEnums new))
      oldEnums = Map.fromList (fmap (\e -> (enumName e, e)) (allEnums old))
  in Map.foldlWithKey'
       ( \acc name newEnum ->
           case Map.lookup name oldEnums of
             Nothing -> acc
             Just oldEnum -> acc <> checkEnumCompat dir name newEnum oldEnum
       )
       mempty
       newEnums


-- | Check compatibility of an enum definition.
checkEnumCompat :: Direction -> Text -> EnumDef -> EnumDef -> CompatResult
checkEnumCompat dir enumPath newEnum oldEnum =
  let newVals = Map.fromList (fmap (\v -> (evNumber v, evName v)) (enumValues newEnum))
      oldVals = Map.fromList (fmap (\v -> (evNumber v, evName v)) (enumValues oldEnum))
      newNums = Map.keysSet newVals
      oldNums = Map.keysSet oldVals
  in -- Values removed
     foldMap
       ( \num ->
           let name = oldVals Map.! num
               path = enumPath <> "." <> name
           in case dir of
                BackwardDir ->
                  makeError
                    ( dirLabel dir
                        <> ": enum value '"
                        <> name
                        <> "' (number "
                        <> T.pack (show num)
                        <> ") removed"
                    )
                    path
                    Error
                    "ENUM_VALUE_REMOVED"
                ForwardDir -> mempty
       )
       (Set.difference oldNums newNums)
       <>
       -- Values added
       foldMap
         ( \num ->
             let name = newVals Map.! num
                 path = enumPath <> "." <> name
             in case dir of
                  ForwardDir ->
                    makeWarning
                      ( dirLabel dir
                          <> ": enum value '"
                          <> name
                          <> "' (number "
                          <> T.pack (show num)
                          <> ") added; "
                          <> "old readers will see the numeric value"
                      )
                      path
                      "ENUM_VALUE_ADDED"
                  BackwardDir -> mempty
         )
         (Set.difference newNums oldNums)
       <>
       -- Values renamed (same number, different name) — problematic for JSON encoding
       foldMap
         ( \num ->
             let newName = newVals Map.! num
                 oldName = oldVals Map.! num
                 path = enumPath <> "." <> newName
             in if newName /= oldName
                  then
                    makeWarning
                      ( dirLabel dir
                          <> ": enum value at number "
                          <> T.pack (show num)
                          <> " renamed from '"
                          <> oldName
                          <> "' to '"
                          <> newName
                          <> "' (breaks JSON compatibility)"
                      )
                      path
                      "ENUM_VALUE_RENAMED"
                  else mempty
         )
         (Set.intersection newNums oldNums)


-- Wire compatibility: two types are wire-compatible if they use the same
-- wire format on the wire. This means data written with one type can be
-- read (if perhaps misinterpreted) with the other.

wireCompatible :: FieldType -> FieldType -> Bool
wireCompatible a b = wireType a == wireType b


data WireGroup = WGVarint | WG64Bit | WG32Bit | WGLenDelim
  deriving stock (Eq)


wireType :: FieldType -> WireGroup
wireType = \case
  FTScalar SDouble -> WG64Bit
  FTScalar SFloat -> WG32Bit
  FTScalar SInt32 -> WGVarint
  FTScalar SInt64 -> WGVarint
  FTScalar SUInt32 -> WGVarint
  FTScalar SUInt64 -> WGVarint
  FTScalar SSInt32 -> WGVarint
  FTScalar SSInt64 -> WGVarint
  FTScalar SFixed32 -> WG32Bit
  FTScalar SFixed64 -> WG64Bit
  FTScalar SSFixed32 -> WG32Bit
  FTScalar SSFixed64 -> WG64Bit
  FTScalar SBool -> WGVarint
  FTScalar SString -> WGLenDelim
  FTScalar SBytes -> WGLenDelim
  FTNamed _ -> WGLenDelim


-- Helpers

fieldMap :: MessageDef -> Map Int FieldDef
fieldMap msg =
  Map.fromList
    (fmap (\fd -> (unFieldNumber (fieldNumber fd), fd)) (messageFields msg))


reservedNumbers :: MessageDef -> Set Int
reservedNumbers msg = Set.fromList $ concatMap go (msgElements msg)
  where
    go (MEReserved (ReservedNumbers ranges)) = concatMap expandRange ranges
    go _ = []
    expandRange (ReservedSingle n) = [n]
    expandRange (ReservedRange lo hi) = [lo .. hi]


showFieldType :: FieldType -> Text
showFieldType = \case
  FTScalar s -> showScalar s
  FTNamed n -> n


showScalar :: ScalarType -> Text
showScalar = \case
  SDouble -> "double"
  SFloat -> "float"
  SInt32 -> "int32"
  SInt64 -> "int64"
  SUInt32 -> "uint32"
  SUInt64 -> "uint64"
  SSInt32 -> "sint32"
  SSInt64 -> "sint64"
  SFixed32 -> "fixed32"
  SFixed64 -> "fixed64"
  SSFixed32 -> "sfixed32"
  SSFixed64 -> "sfixed64"
  SBool -> "bool"
  SString -> "string"
  SBytes -> "bytes"


makeError :: Text -> Text -> Severity -> Text -> CompatResult
makeError msg path sev rule = CompatResult [CompatError msg path sev rule]


makeWarning :: Text -> Text -> Text -> CompatResult
makeWarning msg path rule = CompatResult [CompatError msg path Warning rule]