diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/keiro-core.cabal b/keiro-core.cabal --- a/keiro-core.cabal +++ b/keiro-core.cabal @@ -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, diff --git a/src/Keiro/Codec/Base16Bytes.hs b/src/Keiro/Codec/Base16Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Codec/Base16Bytes.hs @@ -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) diff --git a/src/Keiro/Codec/CalendarDay.hs b/src/Keiro/Codec/CalendarDay.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Codec/CalendarDay.hs @@ -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 diff --git a/src/Keiro/Codec/IdDomain.hs b/src/Keiro/Codec/IdDomain.hs --- a/src/Keiro/Codec/IdDomain.hs +++ b/src/Keiro/Codec/IdDomain.hs @@ -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" diff --git a/src/Keiro/Codec/Refined.hs b/src/Keiro/Codec/Refined.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Codec/Refined.hs @@ -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 diff --git a/src/Keiro/Codec/TextSet.hs b/src/Keiro/Codec/TextSet.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Codec/TextSet.hs @@ -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