diff options
| -rw-r--r-- | lib/render/dune | 5 | ||||
| -rw-r--r-- | lib/render/escape.ml | 87 | ||||
| -rw-r--r-- | lib/render/escape.mli | 28 | ||||
| -rw-r--r-- | test/dune | 2 | ||||
| -rw-r--r-- | test/test_colitur.ml | 3 | ||||
| -rw-r--r-- | test/test_escape.ml | 93 |
6 files changed, 216 insertions, 2 deletions
diff --git a/lib/render/dune b/lib/render/dune new file mode 100644 index 0000000..7880188 --- /dev/null +++ b/lib/render/dune @@ -0,0 +1,5 @@ +(library + (name colitur_render) + (libraries colitur_kernel sexplib) + (preprocess + (pps ppx_sexp_conv))) diff --git a/lib/render/escape.ml b/lib/render/escape.ml new file mode 100644 index 0000000..53fdd46 --- /dev/null +++ b/lib/render/escape.ml @@ -0,0 +1,87 @@ +type flavour = Latex | Groff | Html | Xml | Ics | None_ + +let all = [ Latex; Groff; Html; Xml; Ics; None_ ] + +let to_string = function + | Latex -> "latex" | Groff -> "groff" | Html -> "html" + | Xml -> "xml" | Ics -> "ics" | None_ -> "none" + +let of_string = function + | "latex" -> Some Latex | "groff" -> Some Groff | "html" -> Some Html + | "xml" -> Some Xml | "ics" -> Some Ics | "none" -> Some None_ + | _ -> None + +let of_extension = function + | ".tex" -> Some Latex + | ".ms" | ".mom" | ".me" -> Some Groff + | ".html" | ".htm" -> Some Html + | ".xml" -> Some Xml + | ".ics" -> Some Ics + | ".md" | ".adoc" | ".txt" -> Some None_ + | _ -> None + +(* Replace each character with its expansion, in ONE pass. A sequence of + String.concat replacements would double-escape: "&" -> "\\&" then the + backslash rule would rewrite the backslash it just introduced. *) +let expand f s = + let b = Buffer.create (String.length s + 16) in + String.iter (fun c -> Buffer.add_string b (f c)) s; + Buffer.contents b + +let latex = function + | '\\' -> "\\textbackslash{}" + | '{' -> "\\{" | '}' -> "\\}" + | '$' -> "\\$" | '&' -> "\\&" | '#' -> "\\#" + | '_' -> "\\_" | '%' -> "\\%" + | '^' -> "\\textasciicircum{}" + | '~' -> "\\textasciitilde{}" + | c -> String.make 1 c + +let html = function + | '&' -> "&" | '<' -> "<" | '>' -> ">" + | '"' -> """ | '\'' -> "'" + | c -> String.make 1 c + +let ics = function + | '\\' -> "\\\\" | ';' -> "\\;" | ',' -> "\\," + | '\n' -> "\\n" | '\r' -> "" + | c -> String.make 1 c + +(* groff: a backslash starts an escape, and a '.' or '\'' in COLUMN ONE starts a + request. \& is the zero-width non-printing character that defuses it. *) +let groff s = + let escaped = expand (function '\\' -> "\\e" | c -> String.make 1 c) s in + if String.length escaped > 0 && (escaped.[0] = '.' || escaped.[0] = '\'') then "\\&" ^ escaped + else escaped + +let apply flavour s = + match flavour with + | Latex -> expand latex s + | Groff -> groff s + | Html | Xml -> expand html s + | Ics -> expand ics s + | None_ -> s + +(* RFC 5545 section 3.1. A continuation byte is 0x80-0xBF; backing off to a + non-continuation byte keeps every fold on a character boundary. *) +let fold_ics line = + let n = String.length line in + let b = Buffer.create (n + (n / 70) + 8) in + let is_cont c = Char.code c land 0xC0 = 0x80 in + let rec go pos first = + let limit = if first then 75 else 74 (* the leading space costs one octet *) in + if n - pos <= limit then ( + if not first then Buffer.add_char b ' '; + Buffer.add_string b (String.sub line pos (n - pos)); + Buffer.add_string b "\r\n") + else begin + let cut = ref (pos + limit) in + while !cut > pos && is_cont line.[!cut] do decr cut done; + if not first then Buffer.add_char b ' '; + Buffer.add_string b (String.sub line pos (!cut - pos)); + Buffer.add_string b "\r\n"; + go !cut false + end + in + go 0 true; + Buffer.contents b diff --git a/lib/render/escape.mli b/lib/render/escape.mli new file mode 100644 index 0000000..97cf050 --- /dev/null +++ b/lib/render/escape.mli @@ -0,0 +1,28 @@ +(** Per-flavour escaping for the template engine, plus RFC 5545 line folding. + + Knows nothing about calendars. Pure and total: every function is defined on + every string, and none reads the clock, the environment or the filesystem. *) + +(** The six escaping modes. Markdown, AsciiDoc and plain text all use [None_]: + their metacharacter sets are context-dependent, and escaping them + aggressively produces worse output than not escaping at all (spec section 5). + This is a documented limitation of those flavours. *) +type flavour = Latex | Groff | Html | Xml | Ics | None_ + +val all : flavour list +val to_string : flavour -> string +val of_string : string -> flavour option + +(** [of_extension ".tex"] is [Some Latex]. Returns [None] for an unrecognised + extension: the caller must treat that as an error, never as a fallback to + [None_] (spec section 5 -- guessing wrong here produces malformed output + that looks fine until it does not). *) +val of_extension : string -> flavour option + +(** Escape one interpolated value for [flavour]. *) +val apply : flavour -> string -> string + +(** Fold one unfolded content line per RFC 5545 section 3.1: at most 75 octets + per line, continuation lines prefixed with one space, CRLF terminators, + never splitting a UTF-8 sequence. The returned string ends with CRLF. *) +val fold_ics : string -> string @@ -1,6 +1,6 @@ (test (name test_colitur) - (libraries colitur_kernel rite_ef alcotest qcheck qcheck-alcotest sexplib) + (libraries colitur_kernel colitur_render rite_ef alcotest qcheck qcheck-alcotest sexplib) (deps ../data/ef/sanctoral.sexp ../data/ef/adjustments.sexp diff --git a/test/test_colitur.ml b/test/test_colitur.ml index 76ff685..2295a3f 100644 --- a/test/test_colitur.ml +++ b/test/test_colitur.ml @@ -6,4 +6,5 @@ let () = Test_calendar.suite; Test_precedence_ef.suite; Test_sanctoral_ef.suite; Test_rite_ef.suite; Test_differential.suite; Test_oracle.suite; Test_oracle.suite_2038; Test_oracle.suite_2035; Test_golden.suite; ("lectionary", Test_lectionary.suite); - ("lectionary-ef", Test_lectionary_ef.suite) ] + ("lectionary-ef", Test_lectionary_ef.suite); + Test_escape.suite ] diff --git a/test/test_escape.ml b/test/test_escape.ml new file mode 100644 index 0000000..1587388 --- /dev/null +++ b/test/test_escape.ml @@ -0,0 +1,93 @@ +module E = Colitur_render.Escape + +let check = Alcotest.(check string) + +let test_latex () = + check "ampersand" "\\&" (E.apply E.Latex "&"); + check "percent" "\\%" (E.apply E.Latex "%"); + check "underscore" "\\_" (E.apply E.Latex "_"); + check "braces" "\\{\\}" (E.apply E.Latex "{}"); + check "backslash first" "\\textbackslash{}" (E.apply E.Latex "\\"); + (* A real feast name that would otherwise break a .tex build. *) + check "real name" "Ss.mi Nominis Iesu \\& Mari\xc3\xa6" + (E.apply E.Latex "Ss.mi Nominis Iesu & Mari\xc3\xa6") + +let test_groff () = + check "backslash" "\\e" (E.apply E.Groff "\\"); + (* RG-irrelevant but groff-critical: a leading dot starts a request. *) + check "leading dot" "\\&.Ss" (E.apply E.Groff ".Ss"); + check "leading quote" "\\&'tis" (E.apply E.Groff "'tis"); + check "interior dot untouched" "Ss.mi" (E.apply E.Groff "Ss.mi") + +let test_html_xml () = + check "amp first" "&lt;" (E.apply E.Html "<"); + check "angles" "<b>" (E.apply E.Html "<b>"); + check "quote" """ (E.apply E.Html "\""); + check "xml same" "<b>" (E.apply E.Xml "<b>") + +let test_ics () = + check "comma" "\\," (E.apply E.Ics ","); + check "semicolon" "\\;" (E.apply E.Ics ";"); + check "backslash" "\\\\" (E.apply E.Ics "\\"); + check "newline" "\\n" (E.apply E.Ics "\n") + +let test_none_is_identity () = + check "none" "& < > \\ % {}" (E.apply E.None_ "& < > \\ % {}") + +let test_flavour_names () = + List.iter + (fun f -> Alcotest.(check bool) "roundtrip" true (E.of_string (E.to_string f) = Some f)) + [ E.Latex; E.Groff; E.Html; E.Xml; E.Ics; E.None_ ]; + Alcotest.(check bool) "tex" true (E.of_extension ".tex" = Some E.Latex); + Alcotest.(check bool) "ms" true (E.of_extension ".ms" = Some E.Groff); + Alcotest.(check bool) "mom" true (E.of_extension ".mom" = Some E.Groff); + Alcotest.(check bool) "html" true (E.of_extension ".html" = Some E.Html); + Alcotest.(check bool) "md is none" true (E.of_extension ".md" = Some E.None_); + Alcotest.(check bool) "adoc is none" true (E.of_extension ".adoc" = Some E.None_); + Alcotest.(check bool) "txt is none" true (E.of_extension ".txt" = Some E.None_); + (* Spec section 5: an unknown extension is an ERROR, never a silent fallback. *) + Alcotest.(check bool) "unknown is None" true (E.of_extension ".wat" = None) + +let test_fold_short_line_unchanged () = + check "short" "SUMMARY:Feast\r\n" (E.fold_ics "SUMMARY:Feast") + +let test_fold_long_line () = + let long = "DESCRIPTION:" ^ String.make 200 'x' in + let out = E.fold_ics long in + let lines = String.split_on_char '\n' out in + List.iter + (fun l -> + let l = if l <> "" && l.[String.length l - 1] = '\r' then String.sub l 0 (String.length l - 1) else l in + if String.length l > 75 then Alcotest.failf "line of %d octets exceeds 75" (String.length l)) + (List.filter (fun l -> l <> "") lines); + (* Continuation lines begin with exactly one space (RFC 5545 section 3.1). *) + match lines with + | _ :: second :: _ -> Alcotest.(check bool) "continuation starts with space" true (second.[0] = ' ') + | _ -> Alcotest.fail "expected the line to fold" + +(* RFC 5545 section 3.1 folds on OCTET boundaries; splitting mid-UTF-8 corrupts + Polish and Latin names, which is the whole reason this is not a template job. *) +let test_fold_never_splits_utf8 () = + let long = "SUMMARY:" ^ String.concat "" (List.init 40 (fun _ -> "\xc4\x99\xc5\x9b\xc4\x87")) in + let out = E.fold_ics long in + let stripped = + String.concat "" + (List.filter_map + (fun l -> + let l = if l <> "" && l.[String.length l - 1] = '\r' then String.sub l 0 (String.length l - 1) else l in + if l = "" then None else if l.[0] = ' ' then Some (String.sub l 1 (String.length l - 1)) else Some l) + (String.split_on_char '\n' out)) + in + check "unfolds to the original" long stripped + +let suite = + ( "Escape", + [ Alcotest.test_case "latex" `Quick test_latex; + Alcotest.test_case "groff" `Quick test_groff; + Alcotest.test_case "html/xml" `Quick test_html_xml; + Alcotest.test_case "ics" `Quick test_ics; + Alcotest.test_case "none is identity" `Quick test_none_is_identity; + Alcotest.test_case "flavour names" `Quick test_flavour_names; + Alcotest.test_case "fold: short unchanged" `Quick test_fold_short_line_unchanged; + Alcotest.test_case "fold: long line" `Quick test_fold_long_line; + Alcotest.test_case "fold: never splits utf8" `Quick test_fold_never_splits_utf8 ] ) |