1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
module type CONFIGURABLE = sig
type configuration
val parse : Sexplib.Sexp.t -> (configuration, Condition.condition) result
end
module Error = struct
open Condition
let unknown_section key =
condition "unknown-section" "Unknown configuration section" ("key" |=| Value.String key)
let duplicate_section key =
condition "duplicate-section" "Duplicate configuration section" ("key" |=| Value.String key)
let empty_section key =
condition "empty-section" "Empty configuration section (expected a tagged value)"
("key" |=| Value.String key)
let multiple_values_in_section key =
condition "multiple-values-in-section"
"Configuration section contains multiple values (expected exactly one)"
("key" |=| Value.String key)
let invalid_toplevel toplevel =
condition "invalid-toplevel" "Configuration must be a (server ...) s-expression"
("expression" |=| Value.String (Sexplib.Sexp.to_string toplevel))
let malformed_section expr =
condition "malformed-section" "Section must be a (tag ...) s-expression"
("expression" |=| Value.String (Sexplib.Sexp.to_string expr))
let missing_section name =
condition "missing-section" "Missing section in configuration" ("name" |=| Value.String name)
let invalid_tag section tag valid_options =
condition "invalid-tag" "Invalid tag for section"
( "section" |=| Value.String section
& "tag" |=| Value.String tag
& "valid-options" |=| Value.String (String.concat " " valid_options) )
let failed_to_load_file path msg =
condition "failed-to-load-file" "Failed to load configuration file"
("path" |=| Value.String path & "message" |=| Value.String msg)
let syntax_error path msg =
condition "syntax-error" "Failed to parse configuration file"
("path" |=| Value.String path & "message" |=| Value.String msg)
end
(** 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
(** 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 Error (Error.unknown_section key)
in
let* () =
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)
(** [(server ...)] sexp -> section map. Rejects unknown/duplicate keys. *)
let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, Condition.condition) result =
let open Sexplib.Sexp in
match sexp with
| List (Atom "server" :: sections) ->
let expected =
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)
in
go Utilities.StringMap.empty sections
| _ -> Error (Error.invalid_toplevel sexp)
(** Read a file from disk and run [parse_server] on it. *)
let load ~expected_keys (path : string) : (t, Condition.condition) 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)
(** [(tag field1 ...)] -> [(tag, List [field1; ...])]. *)
let extract_tagged_section (sexp : Sexplib.Sexp.t) :
(string * Sexplib.Sexp.t, Condition.condition) result =
let open Sexplib.Sexp in
match sexp with
| List (Atom tag :: body) -> Ok (tag, List body)
| _ -> 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, Condition.condition) result =
let ( let* ) = Result.bind 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)
in
Ok (tag, body)
|
