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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
open! Core
open! Import
let ec2_error_module () =
let loc = !Ast_helper.default_loc in
let all_errors = Ec2_errors.enumerate_all () in
let string_to_code =
let case name =
Ast_helper.Exp.case
(Ast_convenience.pstr name)
(Ast_convenience.variant (Shape.capitalized_id name) None)
in
(all_errors |> List.map ~f:(fun { name; description = _ } -> name) |> List.map ~f:case)
@ [ Ast_helper.Exp.case (Ast_convenience.pvar "name") [%expr `Unknown_code name] ]
|> Ast_helper.Exp.match_ [%expr name]
in
let gen_variants enumeration =
let case name typ =
{ prf_desc = Rtag ({ txt = name; loc = Location.none }, false, typ)
; prf_loc = Location.none
; prf_attributes = []
}
in
let cases =
enumeration
|> List.map ~f:(fun { Ec2_errors.name; description = _ } -> name)
|> List.map ~f:(fun name -> case (Shape.capitalized_id name) [])
in
let catch_all_error_case = case "Unknown_code" [ [%type: string] ] in
Ast_helper.Typ.mk (Ptyp_variant (cases @ [ catch_all_error_case ], Closed, None))
in
let common_client_errors =
gen_variants (Ec2_errors.Common_client_errors.enumerate ())
in
let client_errors_for_specific_actions =
gen_variants (Ec2_errors.Client_errors_for_specific_actions.enumerate ())
in
let server_errors = gen_variants (Ec2_errors.Server_errors.enumerate ()) in
[%str
module Ec2_error = struct
type common_client_errors = [%t common_client_errors] [@@deriving sexp]
type client_errors_for_specific_actions = [%t client_errors_for_specific_actions]
[@@deriving sexp]
type server_errors = [%t server_errors] [@@deriving sexp]
type code =
[ common_client_errors
| client_errors_for_specific_actions
| server_errors
]
[@@deriving sexp]
type t = code * string option [@@deriving sexp]
let string_to_code name = [%e string_to_code]
let of_xml = function
| `Data _ as xml ->
failwithf
"Ec2_error.of_xml: expected element, got data: %s"
(Awsm.Xml.to_string xml)
()
| `El (((_, name), _), _) as xml -> (
match name with
| "Response" -> (
let data = function
| `Data s -> s
| `El (_, children) ->
List.map children ~f:(function
| `Data s -> s
| `El _ -> "")
|> Core.String.concat ~sep:""
in
let _request_id = data (Awsm.Xml.child_exn xml "RequestID") in
let errors =
Awsm.Xml.child_exn xml "Errors"
|> Awsm.Xml.all_children
|> List.map ~f:(fun error ->
let code = Awsm.Xml.child_exn error "Code" |> data in
let message = Awsm.Xml.child_exn error "Message" |> data in
string_to_code code, Some message)
in
match errors with
| [] -> failwithf "Ec2_error.of_xml: no errors in Ec2 error response" ()
| [ error ] -> error
| _lst -> failwithf "Ec2_error.of_xml: multiple errors not supported" ())
| name ->
failwithf
"Ec2_error: expected 'Response' tag got '%s': %s"
name
(Awsm.Xml.to_string xml)
())
;;
end]
;;
let preamble ~loc () =
[%str
open! Core
open Awsm
open! Import]
;;
let errors (service : Botodata.service) =
match service.metadata.protocol with
| `json | `rest_json | `rest_xml | `query -> []
| `ec2 -> ec2_error_module ()
;;
let constants ~awsm_service_id service =
Service_structure.constants_of_service ~awsm_service_id service
;;
let constructors ~loc =
[%str
let simple_to_json to_value x = Botodata.Json.value_to_json_scalar (to_value x)
let composed_to_json to_value x = Botodata.Json.value_to_json (to_value x)
let to_query to_value x = Client.Query.of_value (to_value x)
let structure_to_value_aux st ~f =
let filter = function
| k, Some v -> Some (k, v)
| _ -> None
in
let pair k v = k, v in
let defer_value (k, dv) = pair k dv in
List.filter_map st ~f:filter |> List.map ~f:defer_value |> fun x -> `Structure (f x)
;;
let structure_to_value = structure_to_value_aux ~f:Fn.id
let structure_to_wrapped_value ~wrapper ~response =
structure_to_value_aux ~f:(fun x ->
[ wrapper, `Structure x; response, `Structure [] ])
;;]
;;
let mod_of_str s = s |> Ast_convenience.lid |> Ast_helper.Mod.ident
let open_all ~loc =
List.map ~f:(fun s -> [%stri open [%m mod_of_str s] [@@warning "-33"]])
;;
let include_all ~loc = List.map ~f:(fun s -> [%stri include [%m mod_of_str s]])
let structure_singleton ~awsm_service_id ~loc service shape_modules =
preamble ~loc ()
@ constants ~awsm_service_id service
@ errors service
@ constructors ~loc
@ shape_modules
;;
let structure_multi ~awsm_service_id ~loc index service open_submodules shape_modules =
match index with
| 0 ->
preamble ~loc ()
@ open_all ~loc open_submodules
@ constants ~awsm_service_id service
@ errors service
@ constructors ~loc
@ shape_modules
| _ ->
preamble ~loc () @ open_all ~loc open_submodules @ shape_modules
;;
let module_name_of_ml fn = fn |> String.chop_suffix_exn ~suffix:".ml" |> String.capitalize
let make ~awsm_service_id ~submodules (service : Botodata.service) =
let loc = !Ast_helper.default_loc in
let shape_modules = Service_structure.shape_modules service in
match submodules with
| [] ->
let main_module = structure_singleton ~awsm_service_id ~loc service shape_modules in
let submodules = [] in
main_module, submodules
| submodule_fns ->
let num_submodules = List.length submodule_fns in
let submodules = List.map submodule_fns ~f:module_name_of_ml in
let main_module = include_all ~loc submodules in
let shape_modules_groups =
let length =
Float.( / )
(Float.of_int (List.length shape_modules))
(Float.of_int num_submodules)
|> Float.round_up
|> Float.to_int
in
List.chunks_of shape_modules ~length
in
let submodules =
List.mapi submodule_fns ~f:(fun i sub_fn ->
let sub_mods = List.take submodules i in
let sub_shapes = List.nth_exn shape_modules_groups i in
let struct_ =
structure_multi ~awsm_service_id ~loc i service sub_mods sub_shapes
in
sub_fn, struct_)
in
main_module, submodules
;;