Registry.hs

-- | In-memory event schema registry for extra validation of known event names.
module Kansoku.Event.Registry
  ( EventRegistry (..),
    EventSchema (..),
    PropertyPattern (..),
    PropertySpec (..),
    PropertyType (..),
    defaultRegistry,
    governedTraits,
    lookupTrait,
    organizationTraits,
    lookupOrganizationTrait,
    emptyRegistry,
    knownVersions,
    latestSchema,
    lookupSchemaVersion,
    lookupVersions,
    propertyPatternText,
    registerSchema,
  )
where

import Data.List (find, sortOn)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text qualified as Text
import Kansoku.Event.Types (EventName (..))
import Kansoku.Prelude

-- | A loose description of an expected property's JSON type.
data PropertyType = PTString | PTNumber | PTBool | PTObject | PTArray | PTAny
  deriving stock (Generic, Eq, Show)

-- | A syntactic constraint applied after a property's JSON type is validated.
data PropertyPattern = SqlNamePattern | NonEmptyStringPattern | NonNegativeNumberPattern | NonNegativeIntegerPattern | BoundedStringPattern Int | WebVitalMetricPattern
  deriving stock (Generic, Eq, Show)

propertyPatternText :: PropertyPattern -> Text
propertyPatternText = \case
  SqlNamePattern -> "[a-z0-9_.:-]{1,128}"
  NonEmptyStringPattern -> "nonempty string"
  BoundedStringPattern limit -> "string of 1–" <> Text.pack (show limit) <> " Unicode code points"
  WebVitalMetricPattern -> "^(LCP|INP|CLS|FCP|TTFB)$"
  NonNegativeNumberPattern -> "number >= 0"
  NonNegativeIntegerPattern -> "finite integer >= 0"

data PropertySpec = PropertySpec
  { name :: !Text,
    propertyType :: !PropertyType,
    required :: !Bool,
    validationPattern :: !(Maybe PropertyPattern),
    description :: !(Maybe Text)
  }
  deriving stock (Generic, Eq, Show)

data EventSchema = EventSchema
  { eventName :: !EventName,
    version :: !Int,
    note :: !Text,
    properties :: ![PropertySpec]
  }
  deriving stock (Generic, Eq, Show)

-- | Every version list is ascending and has exactly the versions 1..n. Released
-- versions are immutable; replacing an existing pair is intended for
-- idempotent construction, not in-place production schema edits.
newtype EventRegistry = EventRegistry (Map EventName (NonEmpty EventSchema))
  deriving stock (Generic, Eq, Show)

emptyRegistry :: EventRegistry
emptyRegistry = EventRegistry Map.empty

registerSchema :: EventSchema -> EventRegistry -> EventRegistry
registerSchema schema@EventSchema {eventName, version = newVersion} (EventRegistry registry) =
  EventRegistry (Map.alter upsert eventName registry)
  where
    upsert Nothing = Just (schema :| [])
    upsert (Just versions) =
      Just
        ( NonEmpty.fromList
            ( sortOn
                versionOf
                (schema : filter ((/= newVersion) . versionOf) (NonEmpty.toList versions))
            )
        )

lookupVersions :: EventName -> EventRegistry -> Maybe (NonEmpty EventSchema)
lookupVersions name (EventRegistry registry) = Map.lookup name registry

lookupSchemaVersion :: EventName -> Int -> EventRegistry -> Maybe EventSchema
lookupSchemaVersion name version registry =
  find ((== version) . versionOf) . NonEmpty.toList =<< lookupVersions name registry

latestSchema :: EventName -> EventRegistry -> Maybe EventSchema
latestSchema name registry = NonEmpty.last <$> lookupVersions name registry

knownVersions :: EventName -> EventRegistry -> [Int]
knownVersions name registry =
  maybe [] (fmap versionOf . NonEmpty.toList) (lookupVersions name registry)

versionOf :: EventSchema -> Int
versionOf EventSchema {version} = version

defaultRegistry :: EventRegistry
defaultRegistry =
  foldr
    registerSchema
    emptyRegistry
    [ EventSchema
        (EventName "alias")
        1
        "Bind an anonymous identifier to a user; top-level IDs must match. Works with SDK alias helpers."
        [ PropertySpec "previousId" PTString True (Just NonEmptyStringPattern) (Just "Anonymous identifier; must equal anonymousId."),
          PropertySpec "newId" PTString True (Just NonEmptyStringPattern) (Just "User identifier; must equal userId.")
        ],
      EventSchema
        (EventName "client_error")
        1
        "Short sanitized client error labels only; do not send stack traces or personal data."
        [ PropertySpec "message" PTString True (Just (BoundedStringPattern 256)) (Just "Sanitized error message, 1–256 Unicode code points; do not send stack traces or personal data."),
          PropertySpec "type" PTString True (Just (BoundedStringPattern 128)) (Just "Sanitized error class/category such as TypeError or UnhandledRejection, 1–128 Unicode code points; do not send stack traces or personal data."),
          plainProperty "handled" PTBool True "False for uncaught errors or unhandled rejections; explicit application reports may set true. Do not send stack traces or personal data."
        ],
      EventSchema
        (EventName "web_vital")
        1
        "One page-performance measurement; milliseconds for LCP, INP, FCP and TTFB, unitless for CLS."
        [ PropertySpec "metric" PTString True (Just WebVitalMetricPattern) (Just "LCP (Largest Contentful Paint), INP (Interaction to Next Paint), CLS (Cumulative Layout Shift), FCP (First Contentful Paint), or TTFB (Time to First Byte)."),
          PropertySpec "value" PTNumber True (Just NonNegativeNumberPattern) (Just "Nonnegative measurement: milliseconds for LCP, INP, FCP and TTFB; unitless for CLS, which may exceed one. Zero is valid.")
        ],
      EventSchema (EventName "group") 1 "Stamp organization context; requires a nonempty top-level organizationId." [],
      EventSchema (EventName "group") 2 "Set current organization traits; omitted traits remain unchanged." organizationTraits,
      EventSchema
        (EventName "page_leave")
        1
        "Page lifecycle event; not engagement. Top-level URL identifies the page."
        [PropertySpec "durationMs" PTNumber True (Just NonNegativeNumberPattern) (Just "Observed page duration in milliseconds.")],
      EventSchema
        (EventName "page_view")
        1
        initialSchemaNote
        [plainProperty "url" PTString True "Full URL of the viewed page."],
      EventSchema
        (EventName "session_start")
        1
        initialSchemaNote
        [plainProperty "sessionId" PTString True "Client-generated session identifier."],
      EventSchema
        (EventName "identify")
        1
        initialSchemaNote
        [],
      EventSchema (EventName "identify") 2 "Set current governed user traits; requires a nonempty top-level userId. Omitted traits are unchanged; identify v1 remains identity-only." governedTraits,
      EventSchema (EventName "identify_once") 1 "Initialize governed user traits only when no set exists; earliest set-once wins. Requires a nonempty top-level userId." governedTraits,
      EventSchema
        (EventName "user_registered")
        1
        initialSchemaNote
        [plainProperty "userId" PTString True "Identifier of the newly registered user."],
      EventSchema
        (EventName "subscription_started")
        1
        initialSchemaNote
        [ plainProperty "plan" PTString True "Plan identifier the subscription started on.",
          plainProperty "amount" PTNumber False "Monetary amount of the subscription, in the account's currency."
        ],
      EventSchema
        (EventName "payment_completed")
        1
        initialSchemaNote
        [ plainProperty "amount" PTNumber True "Monetary amount of the completed payment, in the account's currency.",
          plainProperty "plan" PTString False "Plan associated with the completed payment."
        ],
      EventSchema
        (EventName "feature_used")
        1
        initialSchemaNote
        [plainProperty "feature" PTString True "Stable identifier of the feature used."],
      -- Emit an exposure when a user is shown a variant, not merely assigned
      -- one. Re-exposures are allowed because analytics count unique users.
      EventSchema
        (EventName "experiment_viewed")
        1
        initialSchemaNote
        [ sqlNameProperty "experiment" "Stable identifier of the experiment.",
          sqlNameProperty "variant" "Variant shown to the user."
        ]
    ]

-- | One catalog owns ingest schemas, storage eligibility and user: dimensions.
-- Changing any trait type requires an explicit storage/schema migration.
governedTraits :: [PropertySpec]
governedTraits =
  [ plainProperty name PTString False ("Current user trait " <> name <> "; analytics observation, never an authorization fact.")
  | name <- ["plan", "signup_source", "initial_plan", "country", "role"]
  ]
    <> [PropertySpec "company_size" PTNumber False (Just NonNegativeIntegerPattern) (Just "Finite nonnegative integer company size; numeric comparisons use Float64.")]

organizationTraits :: [PropertySpec]
organizationTraits =
  [plainProperty name PTString False ("Current organization " <> name) | name <- ["plan", "industry", "country"]]
    <> [PropertySpec "seats" PTNumber False (Just NonNegativeIntegerPattern) (Just "Finite nonnegative integer seat count.")]

lookupOrganizationTrait :: Text -> Maybe PropertySpec
lookupOrganizationTrait key = find (\PropertySpec {name} -> name == key) organizationTraits

lookupTrait :: Text -> Maybe PropertySpec
lookupTrait key = find (\PropertySpec {name} -> name == key) governedTraits

initialSchemaNote :: Text
initialSchemaNote = "Initial schema (kansoku MVP)."

plainProperty :: Text -> PropertyType -> Bool -> Text -> PropertySpec
plainProperty name propertyType required description =
  PropertySpec name propertyType required Nothing (Just description)

sqlNameProperty :: Text -> Text -> PropertySpec
sqlNameProperty name description =
  PropertySpec name PTString True (Just SqlNamePattern) (Just description)