From 063d4058346f7dc03eb0aa5ba394b9a872d3f1e3 Mon Sep 17 00:00:00 2001 From: Lukasz Kasprzak Date: Wed, 19 Aug 2026 08:41:23 +0200 Subject: feat(render): CSV and JSON emitters, and the published contract Both consume the VIEW, not the kernel, so every emitter and every template describe exactly the same fields -- there is one vocabulary, not five. CSV is RFC 4180: a field with a comma is quoted. That is live on real data, not hypothetical -- 'St. Joseph, Spouse of the Bl. Virgin Mary' would otherwise split into two columns. JSON is hand-rolled because the dependency list is frozen and escaping is the only subtlety. Control characters below 0x20 are \u-escaped per RFC 8259 section 7. There are no numbers in the view, deliberately: a consumer never has to guess whether week is 2 or "2". schema/day-v1.json pins the shape. Once a phone subscribes or a site fetches this, it is a promise to strangers -- adding a field is minor, renaming one means /v2/. --- test/test_emit.ml | 77 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) create mode 100644 test/test_emit.ml (limited to 'test/test_emit.ml') diff --git a/test/test_emit.ml b/test/test_emit.ml new file mode 100644 index 0000000..a8fd45c --- /dev/null +++ b/test/test_emit.ml @@ -0,0 +1,77 @@ +module V = Colitur_render.View +module Csv = Colitur_render.Emit_csv +module Json = Colitur_render.Emit_json + +let view_2027 () = Test_view.view_of 2027 + +let test_csv_header_and_rows () = + let out = Csv.year (view_2027 ()) in + let lines = String.split_on_char '\n' out |> List.filter (fun l -> l <> "") in + Alcotest.(check int) "366 lines: header + 365 days" 366 (List.length lines); + Alcotest.(check string) "header" + "date,rite,season,week,slug,rank,colour,subject,name_la,name_en,first,gospel,comms" + (List.hd lines); + Alcotest.(check bool) "first row is 1 January" true + (String.length (List.nth lines 1) > 10 && String.sub (List.nth lines 1) 0 10 = "2027-01-01") + +(* RFC 4180: a field containing a comma, quote or newline is quoted, and an + embedded quote is doubled. Feast names contain commas ("St. Joseph, Spouse + of the Bl. Virgin Mary"), so this is live on real data, not hypothetical. *) +let test_csv_quotes_commas () = + Alcotest.(check string) "comma quoted" "\"a,b\"" (Csv.escape_field "a,b"); + Alcotest.(check string) "quote doubled" "\"a\"\"b\"" (Csv.escape_field "a\"b"); + Alcotest.(check string) "plain unquoted" "ab" (Csv.escape_field "ab"); + let out = Csv.year (view_2027 ()) in + let joseph = + List.find + (fun l -> String.length l > 10 && String.sub l 0 10 = "2027-03-19") + (String.split_on_char '\n' out) + in + Alcotest.(check bool) "the comma in Joseph's name is quoted, not a field break" true + (String.length (String.split_on_char ',' joseph |> List.hd) = 10) + +let test_json_parses_back () = + let out = Json.year (view_2027 ()) in + Alcotest.(check bool) "starts as an object" true (out.[0] = '{'); + let count sub = + let n = String.length sub in + let rec go i acc = + if i + n > String.length out then acc + else go (i + 1) (if String.sub out i n = sub then acc + 1 else acc) + in + go 0 0 + in + Alcotest.(check bool) "has a days array" true (count "\"days\":[" >= 1); + (* Every ISO date the view produced appears in the JSON -- that is the + property under test, not a specific occurrence count. The count is NOT + 1: the view deliberately offers both artefacts at every level (view.mli) + -- the flat top-level [days], each month's own [days], and that month's + [weeks] grid cell -- so an ordinary date's "iso" field appears 3 times. + Verified against the real 2027 engine output (all 365 dates checked); + the one exception is legitimate, not a bug: 2027-04-05 appears 6 times + because the Annunciation (25 March, impeded by Holy Week) transfers to + it under RG 96/98, and its own "to" target string is the identical + literal, tripled by the same structural redundancy. *) + Alcotest.(check int) "1 January appears (flat days + month days + week grid)" 3 + (count "\"2027-01-01\""); + Alcotest.(check int) "31 December appears (flat days + month days + week grid)" 3 + (count "\"2027-12-31\"") + +let test_json_escapes () = + Alcotest.(check string) "quote" "\"a\\\"b\"" (Json.escape_string "a\"b"); + Alcotest.(check string) "backslash" "\"a\\\\b\"" (Json.escape_string "a\\b"); + Alcotest.(check string) "newline" "\"a\\nb\"" (Json.escape_string "a\nb"); + Alcotest.(check string) "tab" "\"a\\tb\"" (Json.escape_string "a\tb"); + (* Control characters below 0x20 must be \u-escaped (RFC 8259 section 7). *) + Alcotest.(check string) "control" "\"a\\u0001b\"" (Json.escape_string "a\001b") + +let test_utf8_passes_through_json () = + Alcotest.(check string) "polish" "\"\xc5\x9awi\xc4\x99tej\"" (Json.escape_string "\xc5\x9awi\xc4\x99tej") + +let suite = + ( "Emit/csv+json", + [ Alcotest.test_case "csv header and rows" `Quick test_csv_header_and_rows; + Alcotest.test_case "csv quotes commas" `Quick test_csv_quotes_commas; + Alcotest.test_case "json parses back" `Quick test_json_parses_back; + Alcotest.test_case "json escapes" `Quick test_json_escapes; + Alcotest.test_case "json passes utf8 through" `Quick test_utf8_passes_through_json ] ) -- cgit v1.3 From 544836cf0f6373a0a753d0953ce7e60fd96337af Mon Sep 17 00:00:00 2001 From: Lukasz Kasprzak Date: Wed, 19 Aug 2026 08:57:42 +0200 Subject: feat(render): XML emitter and schema Element-per-field; attributes carry identity only and there is no mixed content, so a consumer's XPath never has to distinguish the two. Schema validation is an opt-in make check-schema via xmllint, not an in-suite assertion: validating XSD needs an XML library and the dependency list is frozen. It prints SKIPPED loudly when xmllint is absent, because a silent skip reads as a pass. The suite asserts well-formedness properties directly instead. This corrects the design spec, which claimed in-test validation. --- Makefile | 11 ++++++++++- lib/render/emit_xml.ml | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ lib/render/emit_xml.mli | 8 ++++++++ schema/colitur-v1.xsd | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ test/test_colitur.ml | 3 ++- test/test_emit.ml | 34 ++++++++++++++++++++++++++++++++++ 6 files changed, 151 insertions(+), 2 deletions(-) create mode 100644 lib/render/emit_xml.ml create mode 100644 lib/render/emit_xml.mli create mode 100644 schema/colitur-v1.xsd (limited to 'test/test_emit.ml') diff --git a/Makefile b/Makefile index 5b3bb55..0d4d1d5 100644 --- a/Makefile +++ b/Makefile @@ -17,7 +17,7 @@ MAN5DIR := $(PREFIX)/share/man/man5 # over documenting the dune commands. DUNE := opam exec -- -.PHONY: help build test check install uninstall reinstall clean fmt man doc release +.PHONY: help build test check check-schema install uninstall reinstall clean fmt man doc release help: ## show this help @grep -hE '^[a-z-]+:.*##' $(MAKEFILE_LIST) | sed -E 's/:.*## /\t/' | sort @@ -30,6 +30,15 @@ test: ## fast suite (~5s): properties sample 200 years check: ## full gate (~2min): every year 1583-9999, not a sample COLITUR_EXHAUSTIVE_SWEEP=1 $(DUNE) dune test --force +check-schema: build ## validate emitted XML against schema/colitur-v1.xsd (needs xmllint; skipped if absent) + @if command -v xmllint >/dev/null 2>&1; then \ + opam exec -- dune exec colitur -- emit --format xml --from 2027 --to 2027 > /tmp/colitur-check.xml && \ + xmllint --noout --schema schema/colitur-v1.xsd /tmp/colitur-check.xml && \ + echo "xml: valid against schema/colitur-v1.xsd"; \ + else \ + echo "SKIPPED: xmllint not installed -- XML is emitted but NOT schema-validated"; \ + fi + install: build ## install binary, calendar data and man page into PREFIX (default ~/.local) $(DUNE) dune install --prefix $(PREFIX) @mkdir -p $(MANDIR) diff --git a/lib/render/emit_xml.ml b/lib/render/emit_xml.ml new file mode 100644 index 0000000..4e4b51a --- /dev/null +++ b/lib/render/emit_xml.ml @@ -0,0 +1,48 @@ +(* emit_xml.ml *) +module T = Template + +let escape s = Escape.apply Escape.Xml s + +let get v k = match v with T.Obj kvs -> List.assoc_opt k kvs | _ -> None +let s v k = match get v k with Some (T.Str x) -> x | _ -> "" +let el b name value = + Buffer.add_string b (" <" ^ name ^ ">" ^ escape value ^ "\n") + +let day b d = + Buffer.add_string b (" \n"); + el b "season" (s d "season"); + el b "week" (s d "week"); + el b "slug" (s d "slug"); + el b "rank" (s d "rank"); + el b "colour" (s d "colour"); + el b "subject" (s d "subject"); + (match get d "name" with + | Some (T.Obj kvs) -> + List.iter + (fun (lang, v) -> + match v with + | T.Str x -> Buffer.add_string b (" " ^ escape x ^ "\n") + | _ -> ()) + kvs + | _ -> ()); + (match get d "comms" with + | Some (T.List l) -> + List.iter (fun c -> Buffer.add_string b (" " ^ escape (s c "slug") ^ "\n")) l + | _ -> ()); + let cite name value = + if value <> "" then + Buffer.add_string b (" " ^ escape value ^ "\n") + in + cite "first" (s d "first"); + cite "gospel" (s d "gospel"); + Buffer.add_string b " \n" + +let year v = + let b = Buffer.create (128 * 1024) in + Buffer.add_string b "\n"; + Buffer.add_string b + ("\n"); + Buffer.add_string b " \n"; + (match get v "days" with Some (T.List l) -> List.iter (day b) l | _ -> ()); + Buffer.add_string b " \n\n"; + Buffer.contents b diff --git a/lib/render/emit_xml.mli b/lib/render/emit_xml.mli new file mode 100644 index 0000000..4d539d6 --- /dev/null +++ b/lib/render/emit_xml.mli @@ -0,0 +1,8 @@ +(* emit_xml.mli *) +(** Element-per-field XML. Attributes carry identity only (rite, year, date); + everything else is an element, and there is no mixed content -- so a + consumer's XPath never has to distinguish the two. Shape pinned by + schema/colitur-v1.xsd. *) + +val escape : string -> string +val year : Template.value -> string diff --git a/schema/colitur-v1.xsd b/schema/colitur-v1.xsd new file mode 100644 index 0000000..46af9a9 --- /dev/null +++ b/schema/colitur-v1.xsd @@ -0,0 +1,49 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/test/test_colitur.ml b/test/test_colitur.ml index b61eed6..ca61415 100644 --- a/test/test_colitur.ml +++ b/test/test_colitur.ml @@ -11,4 +11,5 @@ let () = Test_template.suite; Test_template.render_suite; Test_view.suite; - Test_emit.suite ] + Test_emit.suite; + Test_emit.xml_suite ] diff --git a/test/test_emit.ml b/test/test_emit.ml index a8fd45c..63bb3d0 100644 --- a/test/test_emit.ml +++ b/test/test_emit.ml @@ -1,6 +1,7 @@ module V = Colitur_render.View module Csv = Colitur_render.Emit_csv module Json = Colitur_render.Emit_json +module Xml = Colitur_render.Emit_xml let view_2027 () = Test_view.view_of 2027 @@ -75,3 +76,36 @@ let suite = Alcotest.test_case "json parses back" `Quick test_json_parses_back; Alcotest.test_case "json escapes" `Quick test_json_escapes; Alcotest.test_case "json passes utf8 through" `Quick test_utf8_passes_through_json ] ) + +(* Substring search shared by the two XML well-formedness checks below, in + place of the brief's inline recursive finder -- same property, clearer to + read. *) +let contains ~needle hay = + let n = String.length needle and h = String.length hay in + let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in + go 0 + +let test_xml_shape () = + let out = Xml.year (view_2027 ()) in + Alcotest.(check bool) "declaration" true + (String.length out > 5 && String.sub out 0 5 = "" out) + +(* Every '<' in the output must open a tag: an unescaped '<' inside a feast + name is the failure that makes a whole feed unparseable. *) +let test_xml_tags_balance () = + let out = Xml.year (view_2027 ()) in + let opens = ref 0 and closes = ref 0 in + String.iter (fun c -> if c = '<' then incr opens else if c = '>' then incr closes) out; + Alcotest.(check int) "every < has a >" !opens !closes + +let test_xml_escapes_data () = + Alcotest.(check string) "amp" "a & b" (Xml.escape "a & b"); + Alcotest.(check string) "angle" "<x>" (Xml.escape "") + +let xml_suite = + ( "Emit/xml", + [ Alcotest.test_case "shape" `Quick test_xml_shape; + Alcotest.test_case "tags balance" `Quick test_xml_tags_balance; + Alcotest.test_case "escapes data" `Quick test_xml_escapes_data ] ) -- cgit v1.3 From 717a6c2032d0df3669333dd52f993e8f84563bc2 Mon Sep 17 00:00:00 2001 From: Lukasz Kasprzak Date: Wed, 19 Aug 2026 11:35:01 +0200 Subject: test(emit): replace two vacuous CSV/XML assertions with real ones The live-data CSV assertion inspected only the first field's length, always the 10-char ISO date, which can never contain a comma -- it could not fail no matter what emit_csv.ml did with the rest of the row. Mutation-proved: replacing emit_csv.ml's escape_field call with identity left every test green while the real output emitted a 14-field row against a 13-column header. Fixed by parsing the row as RFC 4180 actually requires (a small quote-aware splitter) and asserting the field count matches the header, plus asserting the quoted substring appears literally. The XML suite asserted Escape.Xml's correctness in isolation but never that emit_xml.ml actually calls it on every interpolated value. Bypassing one escape call at the name-element site left all tests green while real 2035 output (Sts. Fabian & Sebastian, 20 January) emitted a bare '&' that xmllint rejects. Fixed by adding a live-data test against the 2035 fixture asserting an escaped ampersand is present and no bare one remains. Both new assertions were run against their named mutations and confirmed to redden before being reverted. --- test/test_emit.ml | 114 ++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 103 insertions(+), 11 deletions(-) (limited to 'test/test_emit.ml') diff --git a/test/test_emit.ml b/test/test_emit.ml index 63bb3d0..a22eaaf 100644 --- a/test/test_emit.ml +++ b/test/test_emit.ml @@ -5,6 +5,57 @@ module Xml = Colitur_render.Emit_xml let view_2027 () = Test_view.view_of 2027 +(* Substring search shared by several live-data checks below (CSV, XML), in + place of a repeated inline recursive finder. *) +let contains ~needle hay = + let n = String.length needle and h = String.length hay in + let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in + go 0 + +(* A byte-accurate RFC 4180 field splitter. [String.split_on_char ','] cannot + be trusted to count fields: a correctly QUOTED field is legally allowed to + contain a comma (exactly what Joseph's own name field does below), so a + naive split over-counts by the number of internal commas whether or not + they are correctly quoted -- it cannot tell the difference, which is + precisely why the test this replaced was vacuous. *) +let parse_csv_row line = + let n = String.length line in + let fields = ref [] in + let buf = Buffer.create 32 in + let i = ref 0 in + while !i < n do + if line.[!i] = '"' then begin + incr i; + let closed = ref false in + while (not !closed) && !i < n do + if line.[!i] = '"' then + if !i + 1 < n && line.[!i + 1] = '"' then begin + Buffer.add_char buf '"'; + i := !i + 2 + end + else begin + incr i; + closed := true + end + else begin + Buffer.add_char buf line.[!i]; + incr i + end + done + end + else if line.[!i] = ',' then begin + fields := Buffer.contents buf :: !fields; + Buffer.clear buf; + incr i + end + else begin + Buffer.add_char buf line.[!i]; + incr i + end + done; + fields := Buffer.contents buf :: !fields; + List.rev !fields + let test_csv_header_and_rows () = let out = Csv.year (view_2027 ()) in let lines = String.split_on_char '\n' out |> List.filter (fun l -> l <> "") in @@ -28,8 +79,17 @@ let test_csv_quotes_commas () = (fun l -> String.length l > 10 && String.sub l 0 10 = "2027-03-19") (String.split_on_char '\n' out) in - Alcotest.(check bool) "the comma in Joseph's name is quoted, not a field break" true - (String.length (String.split_on_char ',' joseph |> List.hd) = 10) + (* The check this replaced inspected the length of the FIRST field only -- + always the 10-char ISO date, which can never contain a comma, so it + could never fail. Parse the row as RFC 4180 actually requires + (quote-aware) and check the FIELD COUNT against the header: a comma + that escapes its quoting produces 14 fields, not 13. Also assert the + quoted substring appears literally, byte for byte -- belt and braces, + and closer to what a human reviewing the CSV would actually look for. *) + Alcotest.(check int) "the row has exactly 13 fields, same as the header" + 13 (List.length (parse_csv_row joseph)); + Alcotest.(check bool) "Joseph's comma-bearing name is quoted whole, not split" true + (contains ~needle:"\"St. Joseph, Spouse of the Bl. Virgin Mary\"" joseph) let test_json_parses_back () = let out = Json.year (view_2027 ()) in @@ -77,14 +137,6 @@ let suite = Alcotest.test_case "json escapes" `Quick test_json_escapes; Alcotest.test_case "json passes utf8 through" `Quick test_utf8_passes_through_json ] ) -(* Substring search shared by the two XML well-formedness checks below, in - place of the brief's inline recursive finder -- same property, clearer to - read. *) -let contains ~needle hay = - let n = String.length needle and h = String.length hay in - let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in - go 0 - let test_xml_shape () = let out = Xml.year (view_2027 ()) in Alcotest.(check bool) "declaration" true @@ -104,8 +156,48 @@ let test_xml_escapes_data () = Alcotest.(check string) "amp" "a & b" (Xml.escape "a & b"); Alcotest.(check string) "angle" "<x>" (Xml.escape "") +(* [is_entity_at s i] recognises the five predefined XML entities and a + numeric character reference starting at [s.[i]] = '&'. Anything else + starting at a '&' is a bare, illegal ampersand -- exactly what + [xmllint --noout] refuses a document over. *) +let is_entity_at s i = + let n = String.length s in + let starts_with prefix = + let pn = String.length prefix in + i + pn <= n && String.sub s i pn = prefix + in + starts_with "&" || starts_with "<" || starts_with ">" + || starts_with """ || starts_with "'" + || + (* &#NNN; -- one or more digits then ';'. *) + (i + 2 < n && s.[i + 1] = '#' + && + let j = ref (i + 2) in + while !j < n && s.[!j] >= '0' && s.[!j] <= '9' do + incr j + done; + !j > i + 2 && !j < n && s.[!j] = ';') + +(* Live-data check. [test_xml_escapes_data] above proves [Escape.Xml] is + correct in isolation; it proves nothing about whether [Emit_xml.year] + actually CALLS it on every interpolated value -- bypassing that call + while leaving [Escape.Xml] itself untouched left every test in this suite + green (mutation-proven; see the branch review that found this). Real 2035 + output carries "Sts. Fabian & Sebastian" (20 January) unescaped in the + source data, which is exactly the case that must come out as "&", and + the whole document must then contain no OTHER bare '&' anywhere. *) +let test_xml_escapes_live_data () = + let out = Xml.year (Test_view.view_of 2035) in + Alcotest.(check bool) "Fabian & Sebastian's ampersand is escaped" true + (contains ~needle:"&" out); + let bare = ref 0 in + String.iteri (fun i c -> if c = '&' && not (is_entity_at out i) then incr bare) out; + Alcotest.(check int) "no bare, unescaped '&' anywhere in the document" 0 !bare + let xml_suite = ( "Emit/xml", [ Alcotest.test_case "shape" `Quick test_xml_shape; Alcotest.test_case "tags balance" `Quick test_xml_tags_balance; - Alcotest.test_case "escapes data" `Quick test_xml_escapes_data ] ) + Alcotest.test_case "escapes data" `Quick test_xml_escapes_data; + Alcotest.test_case "escapes live data (2035, Fabian & Sebastian)" `Quick + test_xml_escapes_live_data ] ) -- cgit v1.3