diff options
| -rw-r--r-- | lib/kernel/lectionary.ml | 13 | ||||
| -rw-r--r-- | test/test_lectionary.ml | 27 |
2 files changed, 39 insertions, 1 deletions
diff --git a/lib/kernel/lectionary.ml b/lib/kernel/lectionary.ml index 1da3d1e..2d478e6 100644 --- a/lib/kernel/lectionary.ml +++ b/lib/kernel/lectionary.ml @@ -26,8 +26,21 @@ let load path = | exception Sexplib.Sexp.Parse_error e -> Error (Printf.sprintf "lectionary: %s: %s" path e.err_msg) | exception Sys_error e -> Error (Printf.sprintf "lectionary: %s" e) + (* Mirrors Layer.load/Overlay.load: this sexplib version raises [Failure] + for some malformed inputs (e.g. an unterminated list or string, an + empty file, or a file holding more than one sexp) rather than + [Sexplib.Sexp.Parse_error], so a catch-all here -- placed last among the + exception branches -- is what actually keeps every parse failure inside + [Error] instead of escaping. *) + | exception exn -> Error (Printf.sprintf "lectionary: %s: %s" path (Printexc.to_string exn)) | sexp -> ( match t_of_sexp sexp with | exception Sexplib0.Sexp_conv_error.Of_sexp_error (exn, _) -> Error (Printf.sprintf "lectionary: %s: %s" path (Printexc.to_string exn)) + (* Defence in depth: every conversion below is currently + [Of_sexp_error] (including [Slug.t_of_sexp] on a malformed slug + atom), but [t_of_sexp] is derived and could raise something else + after a future type change -- this catch-all is what would keep + that inside [Error] too, the same reasoning as the outer one above. *) + | exception exn -> Error (Printf.sprintf "lectionary: %s: %s" path (Printexc.to_string exn)) | parsed -> of_entries parsed) diff --git a/test/test_lectionary.ml b/test/test_lectionary.ml index 45a01ab..fba890a 100644 --- a/test/test_lectionary.ml +++ b/test/test_lectionary.ml @@ -53,8 +53,33 @@ let test_sexp_round_trip () = let l' = Lectionary.t_of_sexp (Lectionary.sexp_of_t l) in Alcotest.(check bool) "round trips" true (l = l') +let with_temp_file contents f = + let path = Filename.temp_file "lectionary_test" ".sexp" in + let oc = open_out path in + output_string oc contents; + close_out oc; + Fun.protect ~finally:(fun () -> Sys.remove path) (fun () -> f path) + +let load_is_error contents what = + with_temp_file contents (fun path -> + match Lectionary.load path with + | Error _ -> () + | Ok _ -> Alcotest.fail (what ^ ": expected Error, got Ok")) + +let test_load_never_raises () = + load_is_error "((ef-advent-sunday-1 (" "unterminated list"; + load_is_error "((ef-advent-sunday-1 ((part First) (reference \"x" "unterminated string"; + load_is_error "" "empty file"; + load_is_error "() ()" "more than one sexp"; + load_is_error "not-a-list" "wrong shape"; + load_is_error "((\"NOT A SLUG\" ()))" "invalid slug"; + match Lectionary.load "/nonexistent/path/lectionary.sexp" with + | Error _ -> () + | Ok _ -> Alcotest.fail "missing file: expected Error, got Ok" + let suite = [ ("find present", `Quick, test_find_present); ("find absent", `Quick, test_find_absent); ("duplicate slug rejected", `Quick, test_duplicate_slug_rejected); - ("sexp round-trip", `Quick, test_sexp_round_trip) ] + ("sexp round-trip", `Quick, test_sexp_round_trip); + ("load never raises", `Quick, test_load_never_raises) ] |