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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
type command =
{ name : string
; request : string
; response : string
; event : string option
; ts_request : string
; ts_response : string
; ts_event : string option
}
type t =
{ service_module : string
; types_module : string
; json_module : string
; typescript_types_module : string
; commands : command list
}
let error message = Error message
let assoc path = function
| `Assoc fields -> Ok fields
| _ -> error (path ^ " must be an object")
let field path name fields =
match List.assoc_opt name fields with
| Some value -> Ok value
| None -> error (path ^ "." ^ name ^ " is required")
let non_empty_string path = function
| `String value when String.length value > 0 -> Ok value
| `String _ -> error (path ^ " must be non-empty")
| _ -> error (path ^ " must be a string")
let string_field path name fields =
match field path name fields with
| Error message -> error message
| Ok value -> non_empty_string (path ^ "." ^ name) value
let optional_string_field path name fields =
match List.assoc_opt name fields with
| None -> Ok None
| Some value ->
(match non_empty_string (path ^ "." ^ name) value with
| Ok value -> Ok (Some value)
| Error message -> error message)
let command_of_yojson index json =
let path = Printf.sprintf "commands[%d]" index in
match assoc path json with
| Error message -> error message
| Ok fields ->
let required name = string_field path name fields in
let optional name = optional_string_field path name fields in
(match
required "name",
required "request",
required "response",
optional "event",
optional "ts_request",
optional "ts_response",
optional "ts_event"
with
| Ok name, Ok request, Ok response, Ok event, Ok ts_request, Ok ts_response, Ok ts_event ->
Ok
{ name
; request
; response
; event
; ts_request = Option.value ts_request ~default:request
; ts_response = Option.value ts_response ~default:response
; ts_event = (match ts_event with Some _ -> ts_event | None -> event)
}
| Error message, _, _, _, _, _, _
| _, Error message, _, _, _, _, _
| _, _, Error message, _, _, _, _
| _, _, _, Error message, _, _, _
| _, _, _, _, Error message, _, _
| _, _, _, _, _, Error message, _
| _, _, _, _, _, _, Error message -> error message)
module Names = Set.Make (String)
let check_unique_names commands =
let rec loop seen = function
| [] -> Ok ()
| command :: rest ->
if Names.mem command.name seen then
error ("duplicate command name: " ^ command.name)
else
loop (Names.add command.name seen) rest
in
loop Names.empty commands
let commands_of_yojson = function
| `List commands ->
let rec loop index acc = function
| [] ->
let commands = List.rev acc in
(match check_unique_names commands with
| Ok () -> Ok commands
| Error message -> error message)
| json :: rest ->
(match command_of_yojson index json with
| Ok command -> loop (index + 1) (command :: acc) rest
| Error message -> error message)
in
loop 0 [] commands
| _ -> error "commands must be an array"
let of_yojson json =
match assoc "manifest" json with
| Error message -> error message
| Ok fields ->
let required name = string_field "manifest" name fields in
let typescript_types_module =
match optional_string_field "manifest" "typescript_types_module" fields with
| Ok (Some value) -> Ok value
| Ok None -> Ok "./api_types"
| Error message -> error message
in
(match
required "service_module",
required "types_module",
required "json_module",
typescript_types_module,
field "manifest" "commands" fields
with
| Ok service_module, Ok types_module, Ok json_module, Ok typescript_types_module, Ok commands_json ->
(match commands_of_yojson commands_json with
| Ok commands ->
Ok { service_module; types_module; json_module; typescript_types_module; commands }
| Error message -> error message)
| Error message, _, _, _, _
| _, Error message, _, _, _
| _, _, Error message, _, _
| _, _, _, Error message, _
| _, _, _, _, Error message -> error message)
let read_file path =
let input = open_in_bin path in
Fun.protect
~finally:(fun () -> close_in_noerr input)
(fun () ->
let length = in_channel_length input in
really_input_string input length)
let load_file path =
match read_file path with
| exception Sys_error message -> error message
| text ->
(match Yojson.Safe.from_string text with
| json -> of_yojson json
| exception Yojson.Json_error message -> error ("invalid JSON: " ^ message))