keiro-core 0.17.0.0 → 0.18.0.0

raw patch · 7 files changed

+392/−14 lines, 7 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +40/−0
• keiro-core.cabal +6/−1
• src/Keiro/Codec/Base16Bytes.hs +78/−0
• src/Keiro/Codec/CalendarDay.hs +124/−0
• src/Keiro/Codec/IdDomain.hs +87/−13
• src/Keiro/Codec/Refined.hs +16/−0
• src/Keiro/Codec/TextSet.hs +41/−0

@@ -6,6 +6,46 @@  ## [Unreleased] +## 0.18.0.0 — 2026-09-20+++### Breaking Changes++- `IdDomainContract` gains an explicit closed `IdAdmission` selector, and+  `IdDomainFailure` gains failures for a value outside an admitted UUID version+  set or RFC variant. Exhaustive matches and positional construction must handle+  the new constructors and field.++### New Features++- `Keiro.Codec.IdDomain` adds the frozen+  `keiro-dsl/id-domain/typeid-v5-or-v7/1` contract and domain-parameterized+  `parseKindIdText`/`parseKindIdValue` entry points. Runtime validation and+  Keiki text-pattern evidence now derive their UUID version and variant+  positions from the same admission table. Existing v7 entry points and+  identity bytes are unchanged.+- Four new exposed modules publish the frozen wire policies that `keiro-dsl`'s+  checked value mappings lower to. Each is a total codec owned by Keiro, not a+  consumer validation callback:+  - `Keiro.Codec.CalendarDay` — proleptic Gregorian days. The writer matches+    Aeson's `Day` writer exactly; the reader additionally accepts the+    historically permitted leading plus sign and non-canonical leading zeroes,+    normalizing every accepted spelling. No timezone, locale, clock, or instant+    conversion occurs.+  - `Keiro.Codec.TextSet` — sets of Unicode text. The writer emits one JSON+    string per distinct element in code-point order; the reader accepts any+    array order and duplicate strings. No Unicode normalization or case folding+    occurs.+  - `Keiro.Codec.Base16Bytes` — unrestricted bytes as base16 text. The reader+    accepts upper- and lowercase digits and the empty string; the writer always+    emits lowercase. Prefixes, whitespace, odd-length inputs, and+    non-hexadecimal digits are rejected before a consumer binding receives the+    decoded bytes.+  - `Keiro.Codec.Refined` — the public entry point for Keiro-owned refined+    representation policies, kept separate from the structural and nominal+    codecs so that consumer validation callbacks cannot masquerade as total+    bindings.+ ## 0.17.0.0 — 2026-09-17  ### Other Changes

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: keiro-core-version: 0.17.0.0+version: 0.18.0.0 synopsis: Core contracts for Keiro packages description:   Stable stream, codec, event-stream, and integration-event contracts@@ -47,10 +47,14 @@   import: warnings, shared   exposed-modules:     Keiro.Codec+    Keiro.Codec.Base16Bytes+    Keiro.Codec.CalendarDay     Keiro.Codec.IdDomain     Keiro.Codec.Nominal+    Keiro.Codec.Refined     Keiro.Codec.Structural     Keiro.Codec.Structural.Generic+    Keiro.Codec.TextSet     Keiro.EventStream     Keiro.EventStream.Validate     Keiro.Integration.Event@@ -65,6 +69,7 @@     aeson-casing >=0.2 && <0.3,     base >=4.21 && <5,     bytestring >=0.11 && <0.13,+    containers >=0.6 && <0.8,     deepseq >=1.5 && <1.6,     generic-lens >=2.2 && <2.4,     keiki >=0.9 && <0.10,

@@ -0,0 +1,78 @@+-- | Frozen JSON policy for unrestricted byte strings encoded as base16 text.+--+-- The reader accepts upper- and lowercase ASCII hexadecimal digits and the+-- empty string. The writer always emits lowercase text. Prefixes, whitespace,+-- odd-length inputs, and non-hexadecimal digits are rejected before a consumer+-- binding receives the decoded bytes.+module Keiro.Codec.Base16Bytes+  ( Base16BytesError (..),+    base16BytesCodecPolicyIdentity,+    decodeBase16BytesText,+    encodeBase16Bytes,+    parseBase16Bytes,+    renderBase16Bytes,+  )+where++import Data.Aeson (Value (String), withText)+import Data.Aeson.Types (Parser)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Char (chr, ord)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Word (Word8)++-- | Stable identity embedded in checked mapped wire fingerprints.+base16BytesCodecPolicyIdentity :: Text+base16BytesCodecPolicyIdentity = "keiro-core/base16-bytes/1"++-- | Stable failure categories for the pure base16 reader.+data Base16BytesError+  = Base16BytesOddLength !Int+  | Base16BytesInvalidDigit !Int !Char+  deriving stock (Eq, Show)++-- | Render bytes as lowercase base16 without adding a prefix.+renderBase16Bytes :: ByteString -> Text+renderBase16Bytes = T.pack . concatMap renderByte . BS.unpack+  where+    renderByte byte = [hexDigit (byte `div` 16), hexDigit (byte `mod` 16)]+    hexDigit nibble+      | nibble < 10 = chr (ord '0' + fromIntegral nibble)+      | otherwise = chr (ord 'a' + fromIntegral nibble - 10)++-- | Decode an even-length base16 string into exactly the represented bytes.+decodeBase16BytesText :: Text -> Either Base16BytesError ByteString+decodeBase16BytesText input+  | odd inputLength = Left (Base16BytesOddLength inputLength)+  | otherwise = BS.pack <$> go 0 (T.unpack input)+  where+    inputLength = T.length input+    go _ [] = Right []+    go index (high : low : rest) = do+      highNibble <- decodeDigit index high+      lowNibble <- decodeDigit (index + 1) low+      ((highNibble * 16 + lowNibble) :) <$> go (index + 2) rest+    go index [_] = Left (Base16BytesOddLength (index + 1))++    decodeDigit :: Int -> Char -> Either Base16BytesError Word8+    decodeDigit index character+      | character >= '0' && character <= '9' = Right (fromIntegral (ord character - ord '0'))+      | character >= 'a' && character <= 'f' = Right (fromIntegral (ord character - ord 'a' + 10))+      | character >= 'A' && character <= 'F' = Right (fromIntegral (ord character - ord 'A' + 10))+      | otherwise = Left (Base16BytesInvalidDigit index character)++-- | Encode a byte string as a JSON string using the canonical lowercase form.+encodeBase16Bytes :: ByteString -> Value+encodeBase16Bytes = String . renderBase16Bytes++-- | Parse the policy's JSON representation with stable failure text.+parseBase16Bytes :: Value -> Parser ByteString+parseBase16Bytes = withText "base16 byte string" $ \value ->+  case decodeBase16BytesText value of+    Right bytes -> pure bytes+    Left (Base16BytesOddLength lengthValue) ->+      fail ("base16 byte string must contain an even number of digits; received " <> show lengthValue)+    Left (Base16BytesInvalidDigit index character) ->+      fail ("invalid base16 digit at index " <> show index <> ": " <> show character)

@@ -0,0 +1,124 @@+-- | Frozen JSON policy for proleptic Gregorian calendar days.+--+-- The writer deliberately matches Aeson's 'Day' writer while the reader keeps+-- the historically accepted optional plus sign and non-canonical leading+-- zeroes. Every accepted spelling normalizes through 'renderCalendarDay'.+-- There is no timezone, locale, clock, or instant conversion in this module.+module Keiro.Codec.CalendarDay+  ( calendarDayCodecPolicyIdentity,+    renderCalendarDay,+    encodeCalendarDay,+    parseCalendarDayText,+    parseCanonicalCalendarDayText,+    parseCalendarDay,+  )+where++import Data.Aeson (Value (String), withText)+import Data.Aeson.Types (Parser)+import Data.Char (ord)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time.Calendar (Day, fromGregorianValid, toGregorian)+import Text.Read (readMaybe)++-- | Stable identity for the complete calendar-day JSON policy.+--+-- This identity is part of generated mapped-wire fingerprints. Changing the+-- accepted domain or emitted bytes requires a successor policy identity and a+-- retained reader for this version.+calendarDayCodecPolicyIdentity :: Text+calendarDayCodecPolicyIdentity = "keiro-core/calendar-day/1"++-- | Render a day as @[-]YYYY-MM-DD@ over the complete 'Day' carrier.+--+-- Years 0000 through 0999 are padded to four digits. Negative years down to+-- -0999 carry the sign plus four digits. Larger absolute years are never+-- truncated, and positive years never carry a plus sign.+renderCalendarDay :: Day -> Text+renderCalendarDay value =+  renderYear year <> "-" <> twoDigits month <> "-" <> twoDigits dayOfMonth+  where+    (year, month, dayOfMonth) = toGregorian value++    renderYear candidate+      | candidate >= 1000 = decimal candidate+      | candidate >= 0 = leftPadFour (decimal candidate)+      | candidate >= -999 = "-" <> leftPadFour (decimal (negate candidate))+      | otherwise = decimal candidate++    decimal = T.pack . show+    leftPadFour digits = T.replicate (4 - T.length digits) "0" <> digits+    twoDigits number =+      let tens = number `div` 10+          ones = number `mod` 10+       in T.pack [asciiDigit tens, asciiDigit ones]+    asciiDigit digit = toEnum (ord '0' + digit)++-- | Encode a day as a JSON string under policy v1.+encodeCalendarDay :: Day -> Value+encodeCalendarDay = String . renderCalendarDay++-- | Parse the v1 historical read language.+--+-- The reader accepts the same signed, at-least-four-digit year language used+-- by Aeson 2.2, but without Aeson's implementation-specific 15-digit cap. A+-- leading plus sign and redundant year zeroes are accepted for retained input+-- and normalize through 'renderCalendarDay'. Month and day are always exactly+-- two digits and invalid Gregorian dates are rejected.+parseCalendarDayText :: Text -> Either Text Day+parseCalendarDayText input = do+  (yearText, monthText, dayText) <- splitDate input+  year <- parseYear yearText+  month <- parseTwoDigits "month" monthText+  dayOfMonth <- parseTwoDigits "day" dayText+  maybe+    (Left ("invalid Gregorian calendar day: " <> input))+    Right+    (fromGregorianValid year month dayOfMonth)++-- | Parse only the canonical writer language.+parseCanonicalCalendarDayText :: Text -> Either Text Day+parseCanonicalCalendarDayText input = do+  value <- parseCalendarDayText input+  if renderCalendarDay value == input+    then Right value+    else Left ("non-canonical calendar day: " <> input)++-- | Parse a JSON string under the historical-compatible v1 read policy.+parseCalendarDay :: Value -> Parser Day+parseCalendarDay =+  withText "CalendarDay" $ \input ->+    either (fail . T.unpack) pure (parseCalendarDayText input)++splitDate :: Text -> Either Text (Text, Text, Text)+splitDate input =+  case T.splitOn "-" input of+    [year, month, dayOfMonth] -> Right (year, month, dayOfMonth)+    ["", year, month, dayOfMonth] -> Right ("-" <> year, month, dayOfMonth)+    _ -> Left ("calendar day must use [-]YYYY-MM-DD: " <> input)++parseYear :: Text -> Either Text Integer+parseYear input = do+  let (sign, digits) =+        case T.uncons input of+          Just ('+', rest) -> (1, rest)+          Just ('-', rest) -> (-1, rest)+          _ -> (1, input)+  if T.length digits < 4 || not (asciiDigits digits)+    then Left ("calendar-day year must contain at least four ASCII digits: " <> input)+    else case readMaybe (T.unpack digits) of+      Just value -> Right (sign * value)+      Nothing -> Left ("calendar-day year is not an integer: " <> input)++parseTwoDigits :: Text -> Text -> Either Text Int+parseTwoDigits label input+  | T.length input /= 2 || not (asciiDigits input) =+      Left ("calendar-day " <> label <> " must contain exactly two ASCII digits: " <> input)+  | otherwise =+      case readMaybe (T.unpack input) of+        Just value -> Right value+        Nothing -> Left ("calendar-day " <> label <> " is not an integer: " <> input)++asciiDigits :: Text -> Bool+asciiDigits value = not (T.null value) && T.all (\character -> character >= '0' && character <= '9') value

@@ -1,12 +1,17 @@--- | Published runtime contract for canonical prefix-bearing TypeID-v7 values.+-- | Published runtime contracts for canonical prefix-bearing TypeID values. module Keiro.Codec.IdDomain-  ( IdNormalization (..),+  ( IdAdmission (..),+    IdNormalization (..),     IdDomainContract (..),     IdDomainFailure (..),     enforcedIdDomainVersion,+    v5OrV7IdDomainVersion,     typeIdV7Domain,+    typeIdV5OrV7Domain,     idDomainAcceptsText,     validateIdDomainText,+    parseKindIdText,+    parseKindIdValue,     parseKindIdV7Text,     parseKindIdV7Value,     idDomainTextPattern,@@ -34,11 +39,20 @@     textRepeatBetween,   ) +-- | The closed UUID-version admission policy owned by a declaration. This+-- selects which already-canonical TypeID texts may enter a service; it does not+-- select an ID generator.+data IdAdmission+  = TypeIdV7+  | TypeIdV5OrV7+  deriving stock (Eq, Ord, Show)+ data IdNormalization = CanonicalLowercase   deriving stock (Eq, Ord, Show)  data IdDomainContract = IdDomainContract-  { idDomainVersion :: !Text,+  { idDomainAdmission :: !IdAdmission,+    idDomainVersion :: !Text,     idDomainPrefix :: !Text,     idDomainSeparator :: !Char,     idDomainSuffixLength :: !Int,@@ -53,15 +67,29 @@   | IdDomainWrongPrefix !Text !Text   | IdDomainMalformed !Text   | IdDomainNotUuidV7 !Text+  | IdDomainVersionNotAdmitted !Char+  | IdDomainVariantNotRfc4122 !Char   deriving stock (Eq, Ord, Show)  enforcedIdDomainVersion :: Text enforcedIdDomainVersion = "keiro-dsl/id-domain/typeid-v7/1" +v5OrV7IdDomainVersion :: Text+v5OrV7IdDomainVersion = "keiro-dsl/id-domain/typeid-v5-or-v7/1"+ typeIdV7Domain :: Text -> IdDomainContract-typeIdV7Domain prefix =+typeIdV7Domain = idDomainContract TypeIdV7++typeIdV5OrV7Domain :: Text -> IdDomainContract+typeIdV5OrV7Domain = idDomainContract TypeIdV5OrV7++idDomainContract :: IdAdmission -> Text -> IdDomainContract+idDomainContract admission prefix =   IdDomainContract-    { idDomainVersion = enforcedIdDomainVersion,+    { idDomainAdmission = admission,+      idDomainVersion = case admission of+        TypeIdV7 -> enforcedIdDomainVersion+        TypeIdV5OrV7 -> v5OrV7IdDomainVersion,       idDomainPrefix = prefix,       idDomainSeparator = '_',       idDomainSuffixLength = 26,@@ -74,7 +102,8 @@ idDomainAcceptsText contract = either (const False) (const True) . validateIdDomainText contract  -- | @mmzk-typeid@ intentionally separates canonical parsing from the UUID--- version check, so both operations are part of this frozen contract.+-- version check. Keiro owns the admitted version and RFC-4122 variant tables so+-- a dependency upgrade cannot silently widen a frozen contract. validateIdDomainText :: IdDomainContract -> Text -> Either IdDomainFailure () validateIdDomainText contract input = do   parsed <- case TypeID.parseText input of@@ -91,15 +120,43 @@   if TypeID.toText parsed == input     then pure ()     else Left IdDomainNonCanonical-  maybe (Right ()) (Left . IdDomainNotUuidV7 . T.pack . show) (TypeID.checkTypeID parsed)+  let suffix = T.takeEnd (idDomainSuffixLength contract) input+      versionCharacter = T.index suffix 10+      variantCharacter = T.index suffix 13+  if versionCharacter `elem` admittedVersionCharacters (idDomainAdmission contract)+    then pure ()+    else case idDomainAdmission contract of+      TypeIdV7 -> Left (IdDomainNotUuidV7 "Invalid UUID part!")+      TypeIdV5OrV7 -> Left (IdDomainVersionNotAdmitted versionCharacter)+  if variantCharacter `elem` rfc4122VariantCharacters+    then pure ()+    else case idDomainAdmission contract of+      TypeIdV7 -> Left (IdDomainNotUuidV7 "Invalid UUID part!")+      TypeIdV5OrV7 -> Left (IdDomainVariantNotRfc4122 variantCharacter) +-- | Parse a canonical ID under an explicit declaration-owned admission policy.+-- The result remains the established @KindID prefix@ carrier so existing+-- bindings and generators stay source-compatible.+parseKindIdText :: forall prefix. (ValidPrefix prefix) => IdDomainContract -> Text -> Either IdDomainFailure (KindID prefix)+parseKindIdText contract input = do+  let expectedPrefix = T.pack (symbolVal (Proxy @prefix))+  if idDomainPrefix contract == expectedPrefix+    then pure ()+    else Left (IdDomainWrongPrefix expectedPrefix (idDomainPrefix contract))+  validateIdDomainText contract input+  either (Left . IdDomainMalformed . T.pack . show) Right (KindID.parseText @prefix input)++-- | Aeson parser for a generated integration-contract field under an explicit+-- declaration-owned admission policy.+parseKindIdValue :: forall prefix. (ValidPrefix prefix) => IdDomainContract -> Value -> Parser (KindID prefix)+parseKindIdValue contract = withText "KindID" $ \input ->+  either (fail . T.unpack . renderIdDomainFailure) pure (parseKindIdText @prefix contract input)+ -- | Parse a canonical TypeID-v7 whose prefix is reflected in the result type. -- Keiro's frozen admission policy runs before the dependency constructs the -- prefix-indexed value, so generated consumers cannot accidentally widen it. parseKindIdV7Text :: forall prefix. (ValidPrefix prefix) => Text -> Either IdDomainFailure (KindID prefix)-parseKindIdV7Text input = do-  validateIdDomainText (typeIdV7Domain expectedPrefix) input-  either (Left . IdDomainMalformed . T.pack . show) Right (KindID.parseText @prefix input)+parseKindIdV7Text = parseKindIdText @prefix (typeIdV7Domain expectedPrefix)   where     expectedPrefix = T.pack (symbolVal (Proxy @prefix)) @@ -107,8 +164,9 @@ -- @explicitParseField@, Aeson attaches the owning field key to these stable -- Keiro admission failures. parseKindIdV7Value :: forall prefix. (ValidPrefix prefix) => Value -> Parser (KindID prefix)-parseKindIdV7Value = withText "KindID" $ \input ->-  either (fail . T.unpack . renderIdDomainFailure) pure (parseKindIdV7Text @prefix input)+parseKindIdV7Value = parseKindIdValue @prefix (typeIdV7Domain expectedPrefix)+  where+    expectedPrefix = T.pack (symbolVal (Proxy @prefix))  renderIdDomainFailure :: IdDomainFailure -> Text renderIdDomainFailure failure = case failure of@@ -117,6 +175,10 @@     "TypeID prefix mismatch: expected '" <> expected <> "', found '" <> actual <> "'"   IdDomainMalformed reason -> "malformed TypeID text: " <> reason   IdDomainNotUuidV7 reason -> "TypeID suffix is not UUIDv7: " <> reason+  IdDomainVersionNotAdmitted character ->+    "TypeID suffix UUID version is not admitted (encoded version character '" <> T.singleton character <> "')"+  IdDomainVariantNotRfc4122 character ->+    "TypeID suffix does not use the RFC 4122 variant (encoded variant character '" <> T.singleton character <> "')"  idDomainTextPattern :: IdDomainContract -> Either DomainConstructionError TextPattern idDomainTextPattern contract = do@@ -128,7 +190,7 @@       )   leading <- textCharSet ('0' :| "1234567")   crockford <- textCharSet ('0' :| "123456789abcdefghjkmnpqrstvwxyz")-  version <- textCharSet ('e' :| "f")+  version <- textCharSet (admittedVersionCharacterSet (idDomainAdmission contract))   variant <- textCharSet ('8' :| "9abrstv")   beforeVersion <- textRepeatBetween 9 9 crockford   beforeVariant <- textRepeatBetween 2 2 crockford@@ -150,3 +212,15 @@ idDomainSampleText contract =   (if T.null (idDomainPrefix contract) then "" else idDomainPrefix contract <> "_")     <> "01h455vb4pex5vsknk084sn02q"++admittedVersionCharacters :: IdAdmission -> [Char]+admittedVersionCharacters = toList . admittedVersionCharacterSet+  where+    toList (first :| rest) = first : rest++admittedVersionCharacterSet :: IdAdmission -> NonEmpty Char+admittedVersionCharacterSet TypeIdV7 = 'e' :| "f"+admittedVersionCharacterSet TypeIdV5OrV7 = 'a' :| "bef"++rfc4122VariantCharacters :: [Char]+rfc4122VariantCharacters = "89abrstv"

@@ -0,0 +1,16 @@+-- | Public codecs for Keiro-owned refined representation policies.+--+-- The first policy is unrestricted bytes encoded as base16 text. Keeping the+-- refinement entry point separate from structural and nominal codecs prevents+-- consumer validation callbacks from masquerading as total bindings.+module Keiro.Codec.Refined+  ( Base16BytesError (..),+    base16BytesCodecPolicyIdentity,+    decodeBase16BytesText,+    encodeBase16Bytes,+    parseBase16Bytes,+    renderBase16Bytes,+  )+where++import Keiro.Codec.Base16Bytes

@@ -0,0 +1,41 @@+-- | Frozen JSON policy for sets of Unicode text values.+--+-- The writer emits one JSON string per distinct element in lexicographic+-- Unicode code-point order. The reader accepts any array order and duplicate+-- strings, and normalizes them to a 'Set' before the value reaches generated+-- bindings or transducers. No Unicode normalization or case folding occurs.+module Keiro.Codec.TextSet+  ( textSetCodecPolicyIdentity,+    encodeTextSet,+    parseTextSet,+  )+where++import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value)+import Data.Aeson.Types (Parser)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)++-- | Stable identity for the complete text-set JSON policy.+--+-- This identity is part of generated mapped-wire fingerprints. Changing the+-- accepted domain, duplicate policy, ordering, normalization, case handling,+-- or emitted bytes requires a successor identity and a retained v1 reader.+textSetCodecPolicyIdentity :: Text+textSetCodecPolicyIdentity = "keiro-core/text-set/1"++-- | Encode a set as an ascending, duplicate-free JSON string array.+--+-- 'Text' ordering is lexicographic Unicode code-point order. In particular,+-- U+E000 sorts before U+10000; this is not UTF-16 code-unit ordering.+encodeTextSet :: Set Text -> Value+encodeTextSet = toJSON . Set.toAscList++-- | Parse the v1 historical read language.+--+-- Array order and duplicates are deliberately insignificant. JSON validation+-- still happens before set construction, so non-array input and non-string+-- elements fail with Aeson's located parser diagnostics.+parseTextSet :: Value -> Parser (Set Text)+parseTextSet value = Set.fromList <$> parseJSON value