diff options
Diffstat (limited to 'lib/configuration.ml')
| -rw-r--r-- | lib/configuration.ml | 104 |
1 files changed, 53 insertions, 51 deletions
diff --git a/lib/configuration.ml b/lib/configuration.ml index 12a3681..af1635f 100644 --- a/lib/configuration.ml +++ b/lib/configuration.ml @@ -6,34 +6,50 @@ end module Error = struct open Condition - let unknown_section key = condition "unknown-section" "Unknown configuration section" - ("key" |=| (of_string key)) - let duplicate_section key = condition "duplicate-section" "Duplicate configuration section" - ("key" |=| (of_string key)) - let empty_section key = condition "empty-section" "Empty configuration section (expected a tagged value)" - ("key" |=| (of_string key)) - let multiple_values_in_section key = condition "multiple-values-in-section" "Configuration section contains multiple values (expected exactly one)" - ("key" |=| (of_string key)) - let invalid_toplevel toplevel = condition "invalid-toplevel" "Configuration must be a (server ...) s-expression" - ("expression" |=| (of_sexp toplevel)) - let malformed_section expr = condition "malformed-section" "Section must be a (tag ...) s-expression" - ("expression" |=| (of_sexp expr)) - let missing_section name = condition "missing-section" "Missing section in configuration" - ("name" |=| (of_string name)) - let invalid_tag section tag valid_options = condition "invalid-tag" "Invalid tag for section" - ("section" |=| (of_string section) & - "tag" |=| (of_string tag) & - "valid-options" |=| (of_list of_string valid_options)) - let failed_to_load_file path msg = condition "failed-to-load-file" "Failed to load configuration file" - ("path" |=| (of_string path) & - "message" |=| (of_string msg)) - let syntax_error path msg = condition "syntax-error" "Failed to parse configuration file" - ("path" |=| (of_string path) & - "message" |=| (of_string msg)) + + let unknown_section key = + condition "unknown-section" "Unknown configuration section" ("key" |=| of_string key) + + let duplicate_section key = + condition "duplicate-section" "Duplicate configuration section" ("key" |=| of_string key) + + let empty_section key = + condition "empty-section" "Empty configuration section (expected a tagged value)" + ("key" |=| of_string key) + + let multiple_values_in_section key = + condition "multiple-values-in-section" + "Configuration section contains multiple values (expected exactly one)" + ("key" |=| of_string key) + + let invalid_toplevel toplevel = + condition "invalid-toplevel" "Configuration must be a (server ...) s-expression" + ("expression" |=| of_sexp toplevel) + + let malformed_section expr = + condition "malformed-section" "Section must be a (tag ...) s-expression" + ("expression" |=| of_sexp expr) + + let missing_section name = + condition "missing-section" "Missing section in configuration" ("name" |=| of_string name) + + let invalid_tag section tag valid_options = + condition "invalid-tag" "Invalid tag for section" + ( "section" |=| of_string section + & "tag" |=| of_string tag + & "valid-options" |=| of_list of_string valid_options ) + + let failed_to_load_file path msg = + condition "failed-to-load-file" "Failed to load configuration file" + ("path" |=| of_string path & "message" |=| of_string msg) + + let syntax_error path msg = + condition "syntax-error" "Failed to parse configuration file" + ("path" |=| of_string path & "message" |=| of_string msg) end -type t = Sexplib.Sexp.t Utilities.StringMap.t (** Section name -> raw sexp subtree. *) +type t = Sexplib.Sexp.t Utilities.StringMap.t let find_section (key : string) (config : t) : Sexplib.Sexp.t option = Utilities.StringMap.find_opt key config @@ -42,20 +58,15 @@ let find_section (key : string) (config : t) : Sexplib.Sexp.t option = let insert_section ~expected acc key body = let ( let* ) = Result.bind in let* () = - if Utilities.StringSet.mem key expected then Ok () - else Error (Error.unknown_section key) + if Utilities.StringSet.mem key expected then Ok () else Error (Error.unknown_section key) in let* () = - if Utilities.StringMap.mem key acc then - Error (Error.duplicate_section key) - else Ok () + if Utilities.StringMap.mem key acc then Error (Error.duplicate_section key) else Ok () in match body with - | [ subtree ] -> Ok (Utilities.StringMap.add key subtree acc) - | [] -> - Error (Error.empty_section key) - | _ -> - Error (Error.multiple_values_in_section key) + | [subtree] -> Ok (Utilities.StringMap.add key subtree acc) + | [] -> Error (Error.empty_section key) + | _ -> Error (Error.multiple_values_in_section key) (** [(server ...)] sexp -> section map. Rejects unknown/duplicate keys. *) let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, Condition.t) result = @@ -63,16 +74,13 @@ let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, Condition.t) resul match sexp with | List (Atom "server" :: sections) -> let expected = - List.fold_right Utilities.StringSet.add expected_keys - Utilities.StringSet.empty + List.fold_right Utilities.StringSet.add expected_keys Utilities.StringSet.empty in let rec go acc = function | [] -> Ok acc | List (Atom key :: body) :: rest -> - Result.bind (insert_section ~expected acc key body) (fun acc -> - go acc rest) - | bad :: _ -> - Error (Error.malformed_section bad) + Result.bind (insert_section ~expected acc key body) (fun acc -> go acc rest) + | bad :: _ -> Error (Error.malformed_section bad) in go Utilities.StringMap.empty sections | _ -> Error (Error.invalid_toplevel sexp) @@ -81,14 +89,11 @@ let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, Condition.t) resul let load ~expected_keys (path : string) : (t, Condition.t) result = match Sexplib.Sexp.load_sexp path with | sexp -> parse_server ~expected_keys sexp - | exception Sys_error msg -> - Error (Error.failed_to_load_file path msg) - | exception Failure msg -> - Error (Error.syntax_error path msg) + | exception Sys_error msg -> Error (Error.failed_to_load_file path msg) + | exception Failure msg -> Error (Error.syntax_error path msg) (** [(tag field1 ...)] -> [(tag, List [field1; ...])]. *) -let extract_tagged_section (sexp : Sexplib.Sexp.t) : - (string * Sexplib.Sexp.t, Condition.t) result = +let extract_tagged_section (sexp : Sexplib.Sexp.t) : (string * Sexplib.Sexp.t, Condition.t) result = let open Sexplib.Sexp in match sexp with | List (Atom tag :: body) -> Ok (tag, List body) @@ -98,10 +103,7 @@ let extract_tagged_section (sexp : Sexplib.Sexp.t) : let require_section ~(name : string) ~(valid_tags : string list) (config : t) : (string * Sexplib.Sexp.t, Condition.t) result = let ( let* ) = Result.bind in - let* sexp = - find_section name config - |> Option.to_result ~none:(Error.missing_section name) - in + let* sexp = find_section name config |> Option.to_result ~none:(Error.missing_section name) in let* tag, body = extract_tagged_section sexp in let* () = if List.mem tag valid_tags then Ok () else Error (Error.invalid_tag name tag valid_tags) |