diff options
| -rw-r--r-- | Makefile | 11 | ||||
| -rw-r--r-- | lib/render/emit_xml.ml | 48 | ||||
| -rw-r--r-- | lib/render/emit_xml.mli | 8 | ||||
| -rw-r--r-- | schema/colitur-v1.xsd | 49 | ||||
| -rw-r--r-- | test/test_colitur.ml | 3 | ||||
| -rw-r--r-- | test/test_emit.ml | 34 |
6 files changed, 151 insertions, 2 deletions
@@ -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 ^ "</" ^ name ^ ">\n") + +let day b d = + Buffer.add_string b (" <day date=\"" ^ escape (s d "iso") ^ "\">\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 (" <name lang=\"" ^ escape lang ^ "\">" ^ escape x ^ "</name>\n") + | _ -> ()) + kvs + | _ -> ()); + (match get d "comms" with + | Some (T.List l) -> + List.iter (fun c -> Buffer.add_string b (" <commemoration>" ^ escape (s c "slug") ^ "</commemoration>\n")) l + | _ -> ()); + let cite name value = + if value <> "" then + Buffer.add_string b (" <citation part=\"" ^ name ^ "\">" ^ escape value ^ "</citation>\n") + in + cite "first" (s d "first"); + cite "gospel" (s d "gospel"); + Buffer.add_string b " </day>\n" + +let year v = + let b = Buffer.create (128 * 1024) in + Buffer.add_string b "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"; + Buffer.add_string b + ("<calendar rite=\"" ^ escape (s v "rite") ^ "\" year=\"" ^ escape (s v "year") ^ "\">\n"); + Buffer.add_string b " <days>\n"; + (match get v "days" with Some (T.List l) -> List.iter (day b) l | _ -> ()); + Buffer.add_string b " </days>\n</calendar>\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 @@ +<?xml version="1.0" encoding="UTF-8"?> +<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema" elementFormDefault="qualified"> + <xs:element name="calendar"> + <xs:complexType> + <xs:sequence> + <xs:element name="days"> + <xs:complexType> + <xs:sequence> + <xs:element name="day" maxOccurs="unbounded"> + <xs:complexType> + <xs:sequence> + <xs:element name="season" type="xs:string"/> + <xs:element name="week" type="xs:string"/> + <xs:element name="slug" type="xs:string"/> + <xs:element name="rank" type="xs:string"/> + <xs:element name="colour" type="xs:string"/> + <xs:element name="subject" type="xs:string"/> + <xs:element name="name" minOccurs="0" maxOccurs="unbounded"> + <xs:complexType> + <xs:simpleContent> + <xs:extension base="xs:string"> + <xs:attribute name="lang" type="xs:string" use="required"/> + </xs:extension> + </xs:simpleContent> + </xs:complexType> + </xs:element> + <xs:element name="commemoration" type="xs:string" minOccurs="0" maxOccurs="unbounded"/> + <xs:element name="citation" minOccurs="0" maxOccurs="unbounded"> + <xs:complexType> + <xs:simpleContent> + <xs:extension base="xs:string"> + <xs:attribute name="part" type="xs:string" use="required"/> + </xs:extension> + </xs:simpleContent> + </xs:complexType> + </xs:element> + </xs:sequence> + <xs:attribute name="date" type="xs:string" use="required"/> + </xs:complexType> + </xs:element> + </xs:sequence> + </xs:complexType> + </xs:element> + </xs:sequence> + <xs:attribute name="rite" type="xs:string" use="required"/> + <xs:attribute name="year" type="xs:string" use="required"/> + </xs:complexType> + </xs:element> +</xs:schema> 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 = "<?xml"); + Alcotest.(check bool) "root element" true + (contains ~needle:"<calendar rite=\"ef\" year=\"2027\">" 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 "<x>") + +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 ] ) |