kernel: Slug and Lang validated private strings

Both parse through a smart constructor returning result, and both hand-write
t_of_sexp so a malformed value in a data file is rejected at load rather than
silently accepted -- deriving the converter would have bypassed validation.

6 files changed, 121 insertions, 1 deletions

diff --git a/lib/kernel/lang.ml b/lib/kernel/lang.ml
new file mode 100644
index 0000000..3f45f59
--- /dev/null
+++ b/lib/kernel/lang.ml
@@ -0,0 +1,23 @@
+(* Language codes for celebration names. Two-letter lowercase ISO-639-1; the set
+   is open so an overlay can add a language without a code change (spec §2.1). *)
+type t = string
+
+let of_string s =
+  if String.length s <> 2 then
+    Error (Printf.sprintf "lang %S: expected a 2-letter ISO-639-1 code" s)
+  else if not (String.for_all (fun c -> c >= 'a' && c <= 'z') s) then
+    Error (Printf.sprintf "lang %S: must be lowercase a-z" s)
+  else Ok s
+
+let of_string_exn s = match of_string s with Ok t -> t | Error e -> invalid_arg e
+let to_string t = t
+let compare = String.compare
+let equal = String.equal
+
+let sexp_of_t t = Sexplib0.Sexp_conv.sexp_of_string t
+
+let t_of_sexp sexp =
+  let s = Sexplib0.Sexp_conv.string_of_sexp sexp in
+  match of_string s with
+  | Ok t -> t
+  | Error msg -> Sexplib0.Sexp_conv.of_sexp_error msg sexp
diff --git a/lib/kernel/lang.mli b/lib/kernel/lang.mli
new file mode 100644
index 0000000..6d26a1d
--- /dev/null
+++ b/lib/kernel/lang.mli
@@ -0,0 +1,11 @@
+(** Two-letter lowercase ISO-639-1 language codes. The set is deliberately open:
+    overlays add languages as data, never as code. *)
+type t = private string
+
+val of_string : string -> (t, string) result
+val of_string_exn : string -> t
+val to_string : t -> string
+val compare : t -> t -> int
+val equal : t -> t -> bool
+val t_of_sexp : Sexplib0.Sexp.t -> t
+val sexp_of_t : t -> Sexplib0.Sexp.t
diff --git a/lib/kernel/slug.ml b/lib/kernel/slug.ml
new file mode 100644
index 0000000..5139c99
--- /dev/null
+++ b/lib/kernel/slug.ml
@@ -0,0 +1,29 @@
+(* Stable celebration identifiers. Also the lectionary key: EF slugs are adopted
+   verbatim from lectio so the Plan 3 lectionary bootstrap needs no mapping
+   table (spec §4.4). *)
+type t = string
+
+let valid_char c = (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c = '-'
+
+let of_string s =
+  if String.length s = 0 then Error "slug: empty"
+  else if not (String.for_all valid_char s) then
+    Error (Printf.sprintf "slug %S: only [a-z0-9-] allowed" s)
+  else if s.[0] = '-' || s.[String.length s - 1] = '-' then
+    Error (Printf.sprintf "slug %S: must not start or end with '-'" s)
+  else Ok s
+
+let of_string_exn s = match of_string s with Ok t -> t | Error e -> invalid_arg e
+let to_string t = t
+let compare = String.compare
+let equal = String.equal
+
+let sexp_of_t t = Sexplib0.Sexp_conv.sexp_of_string t
+
+(* Validating parser: a malformed slug in a data file is an error, never a
+   silently-accepted value. Loaders convert the exception to a [result]. *)
+let t_of_sexp sexp =
+  let s = Sexplib0.Sexp_conv.string_of_sexp sexp in
+  match of_string s with
+  | Ok t -> t
+  | Error msg -> Sexplib0.Sexp_conv.of_sexp_error msg sexp
diff --git a/lib/kernel/slug.mli b/lib/kernel/slug.mli
new file mode 100644
index 0000000..0081e2b
--- /dev/null
+++ b/lib/kernel/slug.mli
@@ -0,0 +1,16 @@
+(** Stable celebration identifiers: non-empty [a-z0-9-], no leading or trailing
+    hyphen. Also serve as lectionary keys. *)
+type t = private string
+
+val of_string : string -> (t, string) result
+
+(** For literals in code and tests. Raises [Invalid_argument] on a bad slug. *)
+val of_string_exn : string -> t
+
+val to_string : t -> string
+val compare : t -> t -> int
+val equal : t -> t -> bool
+
+(** Validating; raises [Of_sexp_error] on a malformed slug. *)
+val t_of_sexp : Sexplib0.Sexp.t -> t
+val sexp_of_t : t -> Sexplib0.Sexp.t
diff --git a/test/test_colitur.ml b/test/test_colitur.ml
index c6c5b91..3341c36 100644
--- a/test/test_colitur.ml
+++ b/test/test_colitur.ml
@@ -1,2 +1,4 @@
 (* Aggregating test runner. Per-module suites live in test_<module>.ml. *)
-let () = Alcotest.run "colitur" [ Test_date.suite; Test_computus.suite; Test_colour.suite ]
+let () =
+  Alcotest.run "colitur"
+    [ Test_date.suite; Test_computus.suite; Test_colour.suite; Test_slug.suite ]
diff --git a/test/test_slug.ml b/test/test_slug.ml
new file mode 100644
index 0000000..af70e9a
--- /dev/null
+++ b/test/test_slug.ml
@@ -0,0 +1,39 @@
+module S = Colitur_kernel.Slug
+module L = Colitur_kernel.Lang
+
+let ok_slug s = match S.of_string s with
+  | Ok t -> t | Error e -> Alcotest.failf "slug %S: %s" s e
+
+let test_slug_accepts () =
+  Alcotest.(check string) "plain" "ef-advent-sunday-1" (S.to_string (ok_slug "ef-advent-sunday-1"));
+  Alcotest.(check string) "digits" "ef-lent-3-monday" (S.to_string (ok_slug "ef-lent-3-monday"))
+
+let test_slug_rejects () =
+  List.iter
+    (fun bad ->
+      Alcotest.(check bool) (Printf.sprintf "reject %S" bad) true (Result.is_error (S.of_string bad)))
+    [ ""; "Ef-Advent"; "ef advent"; "ef_advent"; "-leading"; "trailing-"; "ef/advent" ]
+
+let test_slug_sexp () =
+  let s = ok_slug "ef-easter-sunday" in
+  Alcotest.(check bool) "roundtrip" true (S.equal (S.t_of_sexp (S.sexp_of_t s)) s);
+  (* A malformed slug in a data file must be rejected, not silently accepted. *)
+  Alcotest.check_raises "bad slug in sexp"
+    (Sexplib0.Sexp_conv_error.Of_sexp_error
+       (Failure "slug \"Bad Slug\": only [a-z0-9-] allowed", Sexplib0.Sexp.Atom "Bad Slug"))
+    (fun () -> ignore (S.t_of_sexp (Sexplib0.Sexp.Atom "Bad Slug")))
+
+let test_lang () =
+  Alcotest.(check string) "la" "la" (L.to_string (match L.of_string "la" with
+    | Ok t -> t | Error e -> Alcotest.failf "%s" e));
+  List.iter
+    (fun bad ->
+      Alcotest.(check bool) (Printf.sprintf "reject %S" bad) true (Result.is_error (L.of_string bad)))
+    [ ""; "e"; "eng"; "EN"; "e1" ]
+
+let suite =
+  ( "Slug/Lang",
+    [ Alcotest.test_case "slug accepts" `Quick test_slug_accepts;
+      Alcotest.test_case "slug rejects" `Quick test_slug_rejects;
+      Alcotest.test_case "slug sexp validates" `Quick test_slug_sexp;
+      Alcotest.test_case "lang" `Quick test_lang ] )