diff options
| -rw-r--r-- | lib/condition.ml | 2 | ||||
| -rw-r--r-- | lib/configuration.ml | 58 | ||||
| -rw-r--r-- | lib/system.ml | 10 |
3 files changed, 44 insertions, 26 deletions
diff --git a/lib/condition.ml b/lib/condition.ml index e5c44b7..c0e4a12 100644 --- a/lib/condition.ml +++ b/lib/condition.ml @@ -9,6 +9,8 @@ end let of_sexp (expr : Sexplib.Sexp.t) = new literal expr let of_string (s : string) = new literal (Sexplib.Sexp.Atom s) +let of_list (f : 'a -> serializable) (l : 'a list) : serializable = + new literal (Sexplib.Sexp.List (List.map (fun e -> (f e)#as_sexp) l)) type t = { name : string; properties : (string, serializable) BatMap.t } diff --git a/lib/configuration.ml b/lib/configuration.ml index 3f66ac0..151644e 100644 --- a/lib/configuration.ml +++ b/lib/configuration.ml @@ -1,7 +1,28 @@ module type CONFIGURABLE = sig type configuration - val parse : Sexplib.Sexp.t -> (configuration, string) result + val parse : Sexplib.Sexp.t -> (configuration, Condition.t) result +end + +module Error = struct + open Condition + let unknown_section key = condition "unknown-section" ("key" |=| (of_string key)) + let duplicate_section key = condition "duplicate-section" ("key" |=| (of_string key)) + let empty_section key = condition "empty-section" ("key" |=| (of_string key)) + let multiple_values_in_section key = condition "multiple-values-in-section" ("key" |=| (of_string key)) + let invalid_toplevel toplevel = condition "invalid-toplevel" ("expression" |=| (of_sexp toplevel)) + let malformed_section expr = condition "malformed-section" ("expression" |=| (of_sexp expr)) + let missing_section name = condition "missing-section" ("name" |=| (of_string name)) + let invalid_tag section tag valid_options = condition "invalid-tag" + ("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" + ("path" |=| (of_string path) & + "message" |=| (of_string msg)) + let syntax_error path msg = condition "syntax-error" + ("path" |=| (of_string path) & + "message" |=| (of_string msg)) end type t = Sexplib.Sexp.t Utilities.StringMap.t @@ -10,31 +31,27 @@ 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 -let errorf fmt = Printf.ksprintf (fun s -> Error s) fmt - (** Check that [key] is expected and not duplicate, then add it. *) let insert_section ~expected acc key body = let ( let* ) = Result.bind in let* () = if Utilities.StringSet.mem key expected then Ok () - else errorf "Unknown configuration section: %s" key + else Error (Error.unknown_section key) in let* () = if Utilities.StringMap.mem key acc then - errorf "Duplicate configuration section: %s" key + Error (Error.duplicate_section key) else Ok () in match body with | [ subtree ] -> Ok (Utilities.StringMap.add key subtree acc) | [] -> - errorf "Configuration section %s is empty (expected a tagged value)" key + Error (Error.empty_section key) | _ -> - errorf - "Configuration section %s has multiple values (expected exactly one)" - 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, string) result = +let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, Condition.t) result = let open Sexplib.Sexp in match sexp with | List (Atom "server" :: sections) -> @@ -48,39 +65,38 @@ let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, string) result = Result.bind (insert_section ~expected acc key body) (fun acc -> go acc rest) | bad :: _ -> - errorf "Malformed configuration section: %s" (to_string bad) + Error (Error.malformed_section bad) in go Utilities.StringMap.empty sections - | _ -> Error "Configuration must be a (server ...) s-expression" + | _ -> Error (Error.invalid_toplevel sexp) (** Read a file from disk and run [parse_server] on it. *) -let load ~expected_keys (path : string) : (t, string) result = +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 -> - errorf "Failed to load configuration file %s: %s" path msg + Error (Error.failed_to_load_file path msg) | exception Failure msg -> - errorf "Failed to parse configuration file %s: %s" path msg + Error (Error.syntax_error path msg) (** [(tag field1 ...)] -> [(tag, List [field1; ...])]. *) let extract_tagged_section (sexp : Sexplib.Sexp.t) : - (string * Sexplib.Sexp.t, string) result = + (string * Sexplib.Sexp.t, Condition.t) result = let open Sexplib.Sexp in match sexp with | List (Atom tag :: body) -> Ok (tag, List body) - | _ -> errorf "Expected (tag ...) but got: %s" (to_string sexp) + | _ -> Error (Error.malformed_section sexp) (** Look up a section by name, extract its tag, and check the tag is allowed. *) let require_section ~(name : string) ~(valid_tags : string list) (config : t) : - (string * Sexplib.Sexp.t, string) result = + (string * Sexplib.Sexp.t, Condition.t) result = let ( let* ) = Result.bind in let* sexp = find_section name config - |> Option.to_result - ~none:(Printf.sprintf "Missing (%s ...) section in configuration" name) + |> 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 errorf "Unknown %s: %s" name tag + if List.mem tag valid_tags then Ok () else Error (Error.invalid_tag name tag valid_tags) in Ok (tag, body) diff --git a/lib/system.ml b/lib/system.ml index bad6c3b..716b6a8 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -9,8 +9,8 @@ type transport_parcel = (module Transport.TRANSPORT with type t = 't) * 't -> transport_parcel -type nt_provider = Sexplib.Sexp.t -> (nt_parcel, string) result -type transport_provider = Sexplib.Sexp.t -> (transport_parcel, string) result +type nt_provider = Sexplib.Sexp.t -> (nt_parcel, Condition.t) result +type transport_provider = Sexplib.Sexp.t -> (transport_parcel, Condition.t) result type registry = { nt : nt_provider Utilities.StringMap.t; @@ -44,7 +44,7 @@ let registry : registry = Ok (TransportParcel ((module Transport.TCP), transport))); } -let assemble (config : Configuration.t) : (unit -> unit, string) result = +let assemble (config : Configuration.t) : (unit -> unit, Condition.t) result = let open Utilities.Result in let* nt_tag, nt_body = Configuration.require_section ~name:"nt" @@ -71,11 +71,11 @@ let assemble (config : Configuration.t) : (unit -> unit, string) result = let* packed_transport = transport_provider transport_body in let (NtParcel (module NT)) = packed_nt in let (TransportParcel ((module T), transport)) = packed_transport in - let* () = NT.initialize () |> Result.map_error Nt.string_of_error in + let* () = NT.initialize () in let module L = Listener.Make (T) (NT) in Ok (fun () -> L.run transport) -let run_from_config (path : string) : (unit -> unit, string) result = +let run_from_config (path : string) : (unit -> unit, Condition.t) result = let ( let* ) = Result.bind in let* config = Configuration.load ~expected_keys:[ "nt"; "transport" ] path |